diff --git a/CHANGELOG.txt b/CHANGELOG.txt --- a/CHANGELOG.txt +++ b/CHANGELOG.txt @@ -1,3 +1,25 @@ +Changelog ideas-1.5 => ideas.1.6 + +* dynamic strategy combinator that uses the current object/term +* more instances for IsTerm (Maybe, Bool, Map, Set) +* exercise-specific properties (that can be parameterized over its type) +* support for encoding exercise terms in JSON (using an exercise property) +* basic support for Latex and MathJax (in html output) +* extended 'apply' feedback service with buggy rules and restarts +* redesigned (parameterized) transformations +* reimplemented strategy combinator split, based on %>> +* new function defaultMainWith, which takes options +* added 'onefinal' feedback service, which returns a final term in context +* layered design for sub-directories: renaming/moving some modules + (e.g. Ideas.Utils.Prelude) +* Typeable constraint now properly encapsulated in Ref type +* removing (static) documentation generation (unused feature) +* removing Common.Algebra modules (now in the Math domain reasoner) +* fixed escaping of characters in xml +* fixed recognition of exercise IDs in ModeJSON +* fixed processing of Null in EncoderJSON +* fixed rule ordering in function ruleset + Changelog ideas-1.4 => ideas.1.5 * upgrade to ghc-7.10 diff --git a/ideas.cabal b/ideas.cabal --- a/ideas.cabal +++ b/ideas.cabal @@ -1,5 +1,5 @@ name: ideas -version: 1.5 +version: 1.6 synopsis: Feedback services for intelligent tutoring systems homepage: http://ideas.cs.uu.nl/www/ description: @@ -63,17 +63,8 @@ wl-pprint Exposed-modules: - Ideas.Common.Algebra.Boolean - Ideas.Common.Algebra.BooleanLaws - Ideas.Common.Algebra.Field - Ideas.Common.Algebra.FieldLaws - Ideas.Common.Algebra.Group - Ideas.Common.Algebra.GroupLaws - Ideas.Common.Algebra.Law - Ideas.Common.Algebra.SmartGroup Ideas.Common.Classes Ideas.Common.Context - Ideas.Common.CyclicTree Ideas.Common.Derivation Ideas.Common.DerivationTree Ideas.Common.Environment @@ -92,7 +83,6 @@ Ideas.Common.Rewriting.Unification Ideas.Common.Rule Ideas.Common.Rule.Abstract - Ideas.Common.Rule.EnvironmentMonad Ideas.Common.Rule.Parameter Ideas.Common.Rule.Recognizer Ideas.Common.Rule.Transformation @@ -101,6 +91,7 @@ Ideas.Common.Strategy.Choice Ideas.Common.Strategy.Combinators Ideas.Common.Strategy.Configuration + Ideas.Common.Strategy.CyclicTree Ideas.Common.Strategy.Derived Ideas.Common.Strategy.Legacy Ideas.Common.Strategy.Location @@ -114,11 +105,6 @@ Ideas.Common.Traversal.Navigator Ideas.Common.Traversal.Tests Ideas.Common.Traversal.Utils - Ideas.Common.Utils - Ideas.Common.Utils.QuickCheck - Ideas.Common.Utils.StringRef - Ideas.Common.Utils.TestSuite - Ideas.Common.Utils.Uniplate Ideas.Common.View Ideas.Encoding.DecoderJSON Ideas.Encoding.DecoderXML @@ -128,17 +114,17 @@ Ideas.Encoding.EncoderXML Ideas.Encoding.Evaluator Ideas.Encoding.LinkManager + Ideas.Encoding.Logging Ideas.Encoding.ModeJSON Ideas.Encoding.ModeXML Ideas.Encoding.OpenMathSupport + Ideas.Encoding.Options + Ideas.Encoding.Request Ideas.Encoding.RulePresenter Ideas.Encoding.RulesInfo Ideas.Encoding.StrategyInfo - Ideas.Main.BlackBoxTests + Ideas.Main.CmdLineOptions Ideas.Main.Default - Ideas.Main.Documentation - Ideas.Main.Logging - Ideas.Main.Options Ideas.Main.Revision Ideas.Service.BasicServices Ideas.Service.Diagnose @@ -149,13 +135,13 @@ Ideas.Service.FeedbackScript.Syntax Ideas.Service.FeedbackText Ideas.Service.ProblemDecomposition - Ideas.Service.Request Ideas.Service.ServiceList Ideas.Service.State Ideas.Service.Submit Ideas.Service.Types Ideas.Text.HTML Ideas.Text.JSON + Ideas.Text.Latex Ideas.Text.OpenMath.Dictionary.Arith1 Ideas.Text.OpenMath.Dictionary.Calculus1 Ideas.Text.OpenMath.Dictionary.Fns1 @@ -170,13 +156,20 @@ Ideas.Text.OpenMath.Object Ideas.Text.OpenMath.Symbol Ideas.Text.OpenMath.Tests - Ideas.Text.Parsing Ideas.Text.UTF8 Ideas.Text.XML Ideas.Text.XML.Document Ideas.Text.XML.Interface Ideas.Text.XML.Parser Ideas.Text.XML.Unicode + Ideas.Utils.BlackBoxTests + Ideas.Utils.Parsing + Ideas.Utils.Prelude + Ideas.Utils.QuickCheck + Ideas.Utils.StringRef + Ideas.Utils.TestSuite + Ideas.Utils.Typeable + Ideas.Utils.Uniplate -------------------------------------------------------------------------------- diff --git a/src/Ideas/Common/Algebra/Boolean.hs b/src/Ideas/Common/Algebra/Boolean.hs deleted file mode 100644 --- a/src/Ideas/Common/Algebra/Boolean.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Common.Algebra.Boolean - ( -- * Boolean algebra - BoolValue(..), Boolean(..) - , ands, ors, implies, equivalent - -- * CoBoolean (matching) - , CoBoolean(..), conjunctions, disjunctions - -- * Monoids monoid - , DualMonoid(..), And(..), Or(..) - ) where - -import Control.Applicative -import Ideas.Common.Algebra.Group -import Ideas.Common.Classes -import Test.QuickCheck - --------------------------------------------------------- --- Boolean algebra - --- Minimal complete definitions: (true/false, or fromBool) and isTrue/isFalse -class BoolValue a where - true :: a - false :: a - fromBool :: Bool -> a - isTrue :: a -> Bool - isFalse :: a -> Bool - -- default definitions - true = fromBool True - false = fromBool False - fromBool b = if b then true else false - -class BoolValue a => Boolean a where - (<&&>) :: a -> a -> a - (<||>) :: a -> a -> a - complement :: a -> a - -instance BoolValue Bool where - fromBool = id - isTrue = id - isFalse = not - -instance BoolValue b => BoolValue (a -> b) where - fromBool x = const (fromBool x) - isTrue = error "not implemented" - isFalse = error "not implemented" - -instance Boolean Bool where - (<&&>) = (&&) - (<||>) = (||) - complement = not - -instance Boolean b => Boolean (a -> b) where - f <&&> g = \x -> f x <&&> g x - f <||> g = \x -> f x <||> g x - complement = (.) complement - -ands :: Boolean a => [a] -> a -- or use mconcat with And monoid -ands xs | null xs = true - | otherwise = foldr1 (<&&>) xs - -ors :: Boolean a => [a] -> a -ors xs | null xs = false - | otherwise = foldr1 (<||>) xs - -implies :: Boolean a => a -> a -> a -implies a b = complement a <||> b - -equivalent :: Boolean a => a -> a -> a -equivalent a b = (a <&&> b) <||> (complement a <&&> complement b) - --------------------------------------------------------- --- CoBoolean (matching) - -class BoolValue a => CoBoolean a where - isAnd :: a -> Maybe (a, a) - isOr :: a -> Maybe (a, a) - isComplement :: a -> Maybe a - -instance CoBoolean a => CoMonoid (And a) where - isEmpty = isTrue . fromAnd - isAppend = fmap (mapBoth And) . isAnd . fromAnd - -instance CoBoolean a => CoMonoidZero (And a) where - isMonoidZero = isFalse . fromAnd - -instance CoBoolean a => CoMonoid (Or a) where - isEmpty = isFalse . fromOr - isAppend = fmap (mapBoth Or) . isOr . fromOr - -instance CoBoolean a => CoMonoidZero (Or a) where - isMonoidZero = isTrue . fromOr - -conjunctions :: CoBoolean a => a -> [a] -conjunctions = map fromAnd . associativeList . And - -disjunctions :: CoBoolean a => a -> [a] -disjunctions = map fromOr . associativeList . Or - --------------------------------------------------------- --- Dual monoid for a monoid (and for or, and vice versa) - -class MonoidZero a => DualMonoid a where - (><) :: a -> a -> a - dualCompl :: a -> a - --------------------------------------------------------- --- And monoid - -newtype And a = And {fromAnd :: a} - deriving (Show, Eq, Ord, Arbitrary, CoArbitrary) - -instance Functor And where -- could be derived - fmap f = And . f . fromAnd - -instance Applicative And where - pure = And - And f <*> And a = And (f a) - -instance Boolean a => Monoid (And a) where - mempty = pure true - mappend = liftA2 (<&&>) - -instance Boolean a => MonoidZero (And a) where - mzero = pure false - -instance Boolean a => DualMonoid (And a) where - (><) = liftA2 (<||>) - dualCompl = liftA complement - --------------------------------------------------------- --- Or monoid - -newtype Or a = Or {fromOr :: a} - deriving (Show, Eq, Ord, Arbitrary, CoArbitrary) - -instance Functor Or where -- could be derived - fmap f = Or . f . fromOr - -instance Applicative Or where - pure = Or - Or f <*> Or a = Or (f a) - -instance Boolean a => Monoid (Or a) where - mempty = pure false - mappend = liftA2 (<||>) - -instance Boolean a => MonoidZero (Or a) where - mzero = pure true - -instance Boolean a => DualMonoid (Or a) where - (><) = liftA2 (<&&>) - dualCompl = liftA complement diff --git a/src/Ideas/Common/Algebra/BooleanLaws.hs b/src/Ideas/Common/Algebra/BooleanLaws.hs deleted file mode 100644 --- a/src/Ideas/Common/Algebra/BooleanLaws.hs +++ /dev/null @@ -1,108 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Common.Algebra.BooleanLaws - ( -- * Boolean laws - andOverOrLaws, orOverAndLaws - , complementAndLaws, complementOrLaws - , absorptionAndLaws, absorptionOrLaws - , deMorganAnd, deMorganOr - , doubleComplement, complementTrue, complementFalse - , booleanLaws - -- * Law transformer - , fromAndLaw, fromOrLaw - -- * Properties - , propsBoolean - ) where - -import Ideas.Common.Algebra.Boolean -import Ideas.Common.Algebra.Group -import Ideas.Common.Algebra.GroupLaws -import Ideas.Common.Algebra.Law -import Test.QuickCheck hiding ((><)) - --------------------------------------------------------- --- Boolean laws - -andOverOrLaws, orOverAndLaws :: Boolean a => [Law a] -andOverOrLaws = map fromAndLaw dualDistributive -orOverAndLaws = map fromOrLaw dualDistributive - -complementAndLaws, complementOrLaws :: Boolean a => [Law a] -complementAndLaws = map fromAndLaw dualComplement -complementOrLaws = map fromOrLaw dualComplement - -absorptionAndLaws, absorptionOrLaws :: Boolean a => [Law a] -absorptionAndLaws = map fromAndLaw dualAbsorption -absorptionOrLaws = map fromOrLaw dualAbsorption - -deMorganAnd, deMorganOr :: Boolean a => Law a -deMorganAnd = fromAndLaw deMorgan -deMorganOr = fromOrLaw deMorgan - -doubleComplement :: Boolean a => Law a -doubleComplement = law "double-complement" $ \a -> - complement (complement a) :==: a - -complementTrue, complementFalse :: Boolean a => Law a -complementTrue = fromAndLaw dualTrueFalse -complementFalse = fromOrLaw dualTrueFalse - -booleanLaws :: Boolean a => [Law a] -booleanLaws = - map fromAndLaw (idempotent : zeroLaws ++ commutativeMonoidLaws) ++ - map fromOrLaw (idempotent : zeroLaws ++ commutativeMonoidLaws) ++ - andOverOrLaws ++ orOverAndLaws ++ complementAndLaws ++ complementOrLaws ++ - absorptionAndLaws ++ absorptionOrLaws ++ - [deMorganAnd, deMorganOr, doubleComplement, complementTrue, complementFalse] - --------------------------------------------------------- --- Dual laws - -dualDistributive :: DualMonoid a => [Law a] -dualDistributive = - [leftDistributiveFor (<>) (><), rightDistributiveFor (<>) (><)] - -dualAbsorption :: DualMonoid a => [Law a] -dualAbsorption = - [ law "absorption" $ \a b -> a `f` (a `g` b) :==: a - | f <- [(<>), flip (<>)] - , g <- [(><), flip (><)] - ] - -dualComplement :: DualMonoid a => [Law a] -dualComplement = - [ law "complement" $ \a -> dualCompl a <> a :==: mzero - , law "complement" $ \a -> a <> dualCompl a :==: mzero - ] - -dualTrueFalse :: DualMonoid a => Law a -dualTrueFalse = law "true-false" $ dualCompl mempty :==: mzero - -deMorgan :: DualMonoid a => Law a -deMorgan = law "demorgan" $ \a b -> - dualCompl (a <> b) :==: dualCompl a >< dualCompl b - --------------------------------------------------------- --- And laws - -fromAndLaw :: Law (And a) -> Law a -fromAndLaw = mapLaw And fromAnd - -fromOrLaw :: Law (Or a) -> Law a -fromOrLaw = mapLaw Or fromOr - --------------------------------------------------------- --- Tests for Bool instance - -propsBoolean :: [Property] -propsBoolean = map property (booleanLaws :: [Law Bool]) diff --git a/src/Ideas/Common/Algebra/Field.hs b/src/Ideas/Common/Algebra/Field.hs deleted file mode 100644 --- a/src/Ideas/Common/Algebra/Field.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Common.Algebra.Field - ( -- * Semi-ring - SemiRing(..) - -- * Ring - , Ring(..) - -- * Field - , Field(..) - -- * Additive monoid - , Additive(..) - -- * Multiplicative monoid - , Multiplicative(..) - -- * Datatype for safe numeric operators - , SafeNum, safeNum - -- * CoSemiRing, CoRing, and CoField (for matching) - , CoSemiRing(..), CoRing(..), CoField(..) - ) where - -import Control.Monad -import Ideas.Common.Algebra.Group -import Ideas.Common.Classes (mapBoth) -import Test.QuickCheck -import qualified Control.Applicative as A -import qualified Control.Applicative as Applicative - --------------------------------------------------------- --- Semi-ring - -infixl 6 |+| -infixl 7 |*| - -class SemiRing a where - -- additive - (|+|) :: a -> a -> a - zero :: a - sum :: [a] -> a - -- multiplicative - (|*|) :: a -> a -> a - one :: a - product :: [a] -> a - -- default implementation - sum [] = zero - sum xs = foldl1 (|+|) xs - product [] = one - product xs = foldl1 (|*|) xs - --------------------------------------------------------- --- Ring - -infixl 6 |-| - --- Minimal complete definition: plusInverse or <-> -class SemiRing a => Ring a where - plusInverse :: a -> a - (|-|) :: a -> a -> a - -- default definitions - plusInverse = (zero |-|) - a |-| b = a |+| plusInverse b - --------------------------------------------------------- --- Field - -infixl 7 |/| - --- Minimal complete definition: mulInverse or -class Ring a => Field a where - timesInverse :: a -> a - (|/|) :: a -> a -> a - -- default definitions - timesInverse = (one |/|) - a |/| b = a |*| timesInverse b - --------------------------------------------------------- --- Additive monoid - -newtype Additive a = Additive {fromAdditive :: a} - deriving (Show, Eq, Ord, Arbitrary, CoArbitrary) - -instance Functor Additive where -- could be derived - fmap f = Additive . f . fromAdditive - -instance A.Applicative Additive where - pure = Additive - Additive f <*> Additive a = Additive (f a) - -instance SemiRing a => Monoid (Additive a) where - mempty = A.pure zero - mappend = A.liftA2 (|+|) - -instance Ring a => Group (Additive a) where - inverse = A.liftA plusInverse - appendInv = A.liftA2 (|-|) - --------------------------------------------------------- --- Multiplicative monoid - -newtype Multiplicative a = Multiplicative {fromMultiplicative :: a} - deriving (Show, Eq, Ord, Arbitrary, CoArbitrary) - -instance Functor Multiplicative where -- could be derived - fmap f = Multiplicative . f . fromMultiplicative - -instance A.Applicative Multiplicative where - pure = Multiplicative - Multiplicative f <*> Multiplicative a = Multiplicative (f a) - -instance SemiRing a => Monoid (Multiplicative a) where - mempty = A.pure one - mappend = A.liftA2 (|*|) - -instance Field a => Group (Multiplicative a) where - inverse = A.liftA timesInverse - appendInv = A.liftA2 (|/|) - -instance SemiRing a => MonoidZero (Multiplicative a) where - mzero = Multiplicative zero - --------------------------------------------------------- --- Datatype for safe numeric operators - -data SafeNum a = Ok a | Exception String - -safeNum :: SafeNum a -> Either String a -safeNum (Ok a) = Right a -safeNum (Exception s) = Left s - -instance Arbitrary a => Arbitrary (SafeNum a) where - arbitrary = liftM return arbitrary - -instance Eq a => Eq (SafeNum a) where - Ok a == Ok b = a == b - _ == _ = True - -instance Ord a => Ord (SafeNum a) where - Ok a `compare` Ok b = a `compare` b - _ `compare` _ = EQ - -instance Show a => Show (SafeNum a) where - show = either ("Exception: " ++) show . safeNum - -instance Functor SafeNum where - fmap f = either Exception (return . f) . safeNum - -instance Applicative.Applicative SafeNum where - pure = return - (<*>) = ap - -instance Monad SafeNum where - return = Ok - fail = Exception - m >>= f = either Exception f (safeNum m) - -instance Num a => Num (SafeNum a) where - (+) = liftM2 (+) - (*) = liftM2 (*) - (-) = liftM2 (-) - negate = liftM negate - abs = liftM abs - signum = liftM signum - fromInteger = return . fromInteger - -instance (Eq a, Fractional a) => Fractional (SafeNum a) where - a / b = liftM2 (/) a (safeDivisor b) - recip = liftM recip . safeDivisor - fromRational = return . fromRational - -instance Num a => SemiRing (SafeNum a) where - (|+|) = (+) - (|*|) = (*) - zero = 0 - one = 1 - -instance Num a => Ring (SafeNum a) where - plusInverse = negate - (|-|) = (-) - -instance (Eq a, Fractional a) => Field (SafeNum a) where - timesInverse = recip - (|/|) = (/) - -safeDivisor :: (Eq a, Num a) => SafeNum a -> SafeNum a -safeDivisor m = m >>= \a -> - if a == 0 then fail "division by zero" else return a - ------------------------------------------------------------- - -class CoSemiRing a where - -- additive - isPlus :: a -> Maybe (a, a) - isZero :: a -> Bool - -- multiplicative - isTimes :: a -> Maybe (a, a) - isOne :: a -> Bool - --- Minimal complete definition: plusInverse or <-> -class CoSemiRing a => CoRing a where - isNegate :: a -> Maybe a - isMinus :: a -> Maybe (a, a) - -- default definition - isMinus _ = Nothing - -class CoRing a => CoField a where - isRecip :: a -> Maybe a - isDivision :: a -> Maybe (a, a) - -- default definition - isDivision _ = Nothing - -instance CoSemiRing a => CoMonoid (Additive a) where - isEmpty = isZero . fromAdditive - isAppend = fmap (mapBoth Additive) . isPlus . fromAdditive - -instance CoRing a => CoGroup (Additive a) where - isInverse = fmap Additive . isNegate . fromAdditive - isAppendInv = fmap (mapBoth Additive) . isMinus . fromAdditive - -instance CoSemiRing a => CoMonoid (Multiplicative a) where - isEmpty = isOne . fromMultiplicative - isAppend = fmap (mapBoth Multiplicative) . isTimes . fromMultiplicative - -instance CoField a => CoGroup (Multiplicative a) where - isInverse = fmap Multiplicative . isRecip . fromMultiplicative - isAppendInv = fmap (mapBoth Multiplicative) . isDivision . fromMultiplicative - -instance CoSemiRing a => CoMonoidZero (Multiplicative a) where - isMonoidZero = isZero . fromMultiplicative diff --git a/src/Ideas/Common/Algebra/FieldLaws.hs b/src/Ideas/Common/Algebra/FieldLaws.hs deleted file mode 100644 --- a/src/Ideas/Common/Algebra/FieldLaws.hs +++ /dev/null @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Common.Algebra.FieldLaws - ( -- * Semi-ring laws - leftDistributive, rightDistributive - , distributiveLaws, semiRingLaws - -- * Ring laws - , leftNegateTimes, rightNegateTimes - , negateTimesLaws, ringLaws, commutativeRingLaws - , distributiveSubtractionLaws - -- * Field laws - , exchangeInverses, fieldLaws - -- * Laws for additive monoid - , fromAdditiveLaw - -- * Laws for multiplicative monoid - , fromMultiplicativeLaw - -- * Properties - , propsField - ) where - -import Ideas.Common.Algebra.Field -import Ideas.Common.Algebra.GroupLaws -import Ideas.Common.Algebra.Law -import Test.QuickCheck - --------------------------------------------------------- --- Semi-ring laws - -leftDistributive :: SemiRing a => Law a -leftDistributive = leftDistributiveFor (|*|) (|+|) - -rightDistributive :: SemiRing a => Law a -rightDistributive = rightDistributiveFor (|*|) (|+|) - -distributiveLaws :: SemiRing a => [Law a] -distributiveLaws = [leftDistributive, rightDistributive] - -semiRingLaws :: SemiRing a => [Law a] -semiRingLaws = - map fromAdditiveLaw commutativeMonoidLaws ++ - map fromMultiplicativeLaw monoidZeroLaws ++ - distributiveLaws - --------------------------------------------------------- --- Ring laws - -leftNegateTimes :: Ring a => Law a -leftNegateTimes = law "left-negate-times" $ \a b -> - plusInverse a |*| b :==: plusInverse (a |*| b) - -rightNegateTimes :: Ring a => Law a -rightNegateTimes = law "right-negate-times" $ \a b -> - a |*| plusInverse b :==: plusInverse (a |*| b) - -negateTimesLaws :: Ring a => [Law a] -negateTimesLaws = [leftNegateTimes, rightNegateTimes] - -ringLaws :: Ring a => [Law a] -ringLaws = - map fromAdditiveLaw abelianGroupLaws ++ - map fromMultiplicativeLaw monoidZeroLaws ++ - distributiveLaws ++ negateTimesLaws - -commutativeRingLaws :: Ring a => [Law a] -commutativeRingLaws = - fromMultiplicativeLaw commutative : ringLaws - -distributiveSubtractionLaws :: Ring a => [Law a] -distributiveSubtractionLaws = - [leftDistributiveFor (|*|) (|-|), rightDistributiveFor (|*|) (|-|)] - --------------------------------------------------------- --- Field laws - -exchangeInverses :: Field a => Law a -exchangeInverses = law "exchange-inverses" $ \a -> - timesInverse (plusInverse a) :==: plusInverse (timesInverse a) - -fieldLaws :: Field a => [Law a] -fieldLaws = - map fromAdditiveLaw abelianGroupLaws ++ - map fromMultiplicativeLaw abelianGroupLaws ++ - distributiveLaws ++ negateTimesLaws ++ [exchangeInverses] - --------------------------------------------------------- --- Laws for additive monoid - -fromAdditiveLaw :: Law (Additive a) -> Law a -fromAdditiveLaw = mapLaw Additive fromAdditive - --------------------------------------------------------- --- Laws for multiplicative monoid - -fromMultiplicativeLaw :: Law (Multiplicative a) -> Law a -fromMultiplicativeLaw = mapLaw Multiplicative fromMultiplicative - --------------------------------------------------------- --- Properties - -propsField :: [Property] -propsField = map property (fieldLaws :: [Law (SafeNum Rational)]) diff --git a/src/Ideas/Common/Algebra/Group.hs b/src/Ideas/Common/Algebra/Group.hs deleted file mode 100644 --- a/src/Ideas/Common/Algebra/Group.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Common.Algebra.Group - ( -- * Monoids - Monoid(..), (<>) - -- * Groups - , Group(..), (<>-) - -- * Monoids with a zero element - , MonoidZero(..), WithZero, fromWithZero - -- * CoMonoid, CoGroup, and CoMonoidZero (for matching) - , CoMonoid(..), CoGroup(..), CoMonoidZero(..) - , associativeList - ) where - -import Control.Applicative -import Control.Monad (liftM2) -import Data.Maybe -import Data.Monoid -import Ideas.Common.Classes -import qualified Data.Set as S - --------------------------------------------------------- --- Groups - --- | Minimal complete definition: inverse or appendInverse -class Monoid a => Group a where - inverse :: a -> a - appendInv :: a -> a -> a - -- default definitions - inverse = (mempty <>-) - appendInv a b = a <> inverse b - -infixl 6 <>- - -(<>-) :: Group a => a -> a -> a -(<>-) = appendInv - --------------------------------------------------------- --- Monoids with a zero element --- This element could be the additive identity from a (semi-)ring for --- the multiplicative monoid - -class Monoid a => MonoidZero a where - mzero :: a - --- Type that adds a zero element -newtype WithZero a = WZ { fromWithZero :: Maybe a } - deriving (Eq, Ord, Functor, Foldable, Applicative) - -instance Monoid a => Monoid (WithZero a) where - mempty = WZ (Just mempty) - mappend x y = WZ (liftM2 mappend (fromWithZero x) (fromWithZero y)) - -instance Monoid a => MonoidZero (WithZero a) where - mzero = WZ Nothing - -instance Traversable WithZero where - traverse f = liftA WZ . traverse f . fromWithZero - --------------------------------------------------------- --- Groups - -class CoMonoid a where - isEmpty :: a -> Bool - isAppend :: a -> Maybe (a, a) - -class CoMonoid a => CoGroup a where - isInverse :: a -> Maybe a - isAppendInv :: a -> Maybe (a, a) - -- default definition - isAppendInv = const Nothing - -class CoMonoid a => CoMonoidZero a where - isMonoidZero :: a -> Bool - -fromSemiGroup :: (CoMonoid a, Monoid b) => (a -> b) -> a -> b -fromSemiGroup f = rec - where - rec a = maybe (f a) make (isAppend a) - make (x, y) = rec x <> rec y -{- -fromMonoid :: (CoMonoid a, Monoid b) => (a -> b) -> a -> b -fromMonoid f = fromSemiGroup $ \a -> - if isEmpty a then mempty else f a - -fromGroup :: (CoGroup a, Group b) => (a -> b) -> a -> b -fromGroup f = rec - where - rec = fromMonoid $ \a -> - case isInverse a of - Just x -> inverse (rec x) - Nothing -> - case isAppendInverse a of - Just (x, y) -> rec x <>- rec y - Nothing -> f a - -fromMonoidZero :: (CoMonoidZero a, MonoidZero b) => (a -> b) -> a -> b -fromMonoidZero f = fromMonoid $ \a -> - if isZero a then zero else f a - ----------------------- --} -associativeList :: CoMonoid a => a -> [a] -associativeList = fromSemiGroup singleton -{- -monoidList :: CoMonoid a => a -> [a] -monoidList = fromMonoid singleton - --- For commutative (and associative) monoids -monoidMultiSet :: (CoMonoid a, Ord a) => a -> MultiSet a -monoidMultiSet = fromMonoid singleton - --- For associative, commutative, idempotent (ACI) monoids -monoidSet :: (CoMonoid a, Ord a) => a -> S.Set a -monoidSet = fromMonoid singleton - -groupSequence :: (CoGroup a, Eq a) => a -> GroupSequence a -groupSequence = fromGroup singleton - -abelianMultiSet :: (CoGroup a, Ord a) => a -> MultiSet a -abelianMultiSet = fromGroup singleton - -monoidZeroList :: CoMonoidZero a => a -> WithZero [a] -monoidZeroList = fromMonoidZero (pure . singleton) - ----------------------- - -newtype MultiSet a = MS (M.Map a Int) - -instance Collection MultiSet where - singleton a = MS (M.singleton a 1) - -instance Ord a => Monoid (MultiSet a) where - mempty = MS mempty - mappend (MS m1) (MS m2) = MS (M.unionWith (+) m1 m2) - -instance Ord a => Group (MultiSet a) where - inverse (MS m) = MS (fmap negate m) - ----------------------- - -newtype GroupSequence a = GS (Q.Seq (a, Bool)) - -instance Collection GroupSequence where - singleton a = GS (Q.singleton (a, False)) - -instance Eq a => Monoid (GroupSequence a) where - mempty = GS mempty - mappend (GS xs) (GS ys) = - case (Q.viewr xs, Q.viewl ys) of - (as Q.:> (a, ai), (b, bi) Q.:< bs) | a == b && ai /= bi -> - mappend (GS as) (GS bs) - _ -> GS (xs <> ys) - -instance Eq a => Group (GroupSequence a) where - inverse (GS xs) = GS (fmap (second not) xs) -- actually: reverse order!! --} ----------------------- - -instance CoMonoid [a] where - isEmpty = null - isAppend (x:xs@(_:_)) = Just ([x], xs) - isAppend _ = Nothing - -instance CoMonoid (S.Set a) where - isEmpty = S.null - isAppend s - | S.size s > 1 = Just (mapFirst S.singleton (S.deleteFindMin s)) - | otherwise = Nothing - -{- -instance CoMonoid (Q.Seq a) where - isEmpty = Q.null - isAppend xs - | n > 1 = Just (Q.splitAt (n `div` 2) xs) - | otherwise = Nothing - where - n = Q.length xs --} -instance CoMonoid a => CoMonoid (WithZero a) where - isEmpty = maybe False isEmpty . fromWithZero - isAppend a = fromWithZero a >>= fmap (mapBoth pure) . isAppend - -instance CoMonoid a => CoMonoidZero (WithZero a) where - isMonoidZero = isNothing . fromWithZero diff --git a/src/Ideas/Common/Algebra/GroupLaws.hs b/src/Ideas/Common/Algebra/GroupLaws.hs deleted file mode 100644 --- a/src/Ideas/Common/Algebra/GroupLaws.hs +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Common.Algebra.GroupLaws - ( -- * Monoid laws - associative, leftIdentity - , rightIdentity, identityLaws, monoidLaws, commutativeMonoidLaws - , idempotent - -- * Group laws - , leftInverse, rightInverse, doubleInverse - , inverseIdentity, inverseDistrFlipped, inverseLaws, groupLaws - , appendInverseLaws - -- * Abelian group laws - , commutative, inverseDistr, abelianGroupLaws - -- * Laws for monoids with a zero element - , leftZero, rightZero, zeroLaws, monoidZeroLaws - -- * Generalized laws - , associativeFor, commutativeFor, idempotentFor - , leftDistributiveFor, rightDistributiveFor - ) where - -import Ideas.Common.Algebra.Group -import Ideas.Common.Algebra.Law -import Prelude hiding ((<*>)) - --------------------------------------------------------- --- Monoids - -associative :: Monoid a => Law a -associative = associativeFor (<>) - -leftIdentity :: Monoid a => Law a -leftIdentity = law "left-identity" $ \a -> mempty <> a :==: a - -rightIdentity :: Monoid a => Law a -rightIdentity = law "right-identity" $ \a -> a <> mempty :==: a - -identityLaws :: Monoid a => [Law a] -identityLaws = [leftIdentity, rightIdentity] - -monoidLaws :: Monoid a => [Law a] -monoidLaws = associative : identityLaws - -commutativeMonoidLaws :: Monoid a => [Law a] -commutativeMonoidLaws = monoidLaws ++ [commutative] - --- | Not all monoids are idempotent (see: idempotentFor) -idempotent :: Monoid a => Law a -idempotent = idempotentFor (<>) - --------------------------------------------------------- --- Groups - -leftInverse :: Group a => Law a -leftInverse = law "left-inverse" $ \a -> inverse a <> a :==: mempty - -rightInverse :: Group a => Law a -rightInverse = law "right-inverse" $ \a -> a <> inverse a :==: mempty - -doubleInverse :: Group a => Law a -doubleInverse = law "double-inverse" $ \a -> inverse (inverse a) :==: a - -inverseIdentity :: Group a => Law a -inverseIdentity = law "inverse-identity" $ inverse mempty :==: mempty - -inverseDistrFlipped :: Group a => Law a -inverseDistrFlipped = law "inverse-distr-flipped" $ \a b -> - inverse (a <> b) :==: inverse b <> inverse a - -inverseLaws :: Group a => [Law a] -inverseLaws = [leftInverse, rightInverse] - -groupLaws :: Group a => [Law a] -groupLaws = monoidLaws ++ inverseLaws ++ - [doubleInverse, inverseIdentity, inverseDistrFlipped] - -appendInverseLaws :: Group a => [Law a] -appendInverseLaws = - [ make 1 $ \a b -> a <>- b :==: a <> inverse b - , make 2 $ \a -> a <>- a :==: mempty - , make 3 $ \a -> a <>- mempty :==: a - , make 4 $ \a -> mempty <>- a :==: inverse a - , make 5 $ \a b c -> a <>- (b <> c) :==: (a <>- b) <>- c - , make 6 $ \a b c -> a <>- (b <>- c) :==: (a <>- b) <> c - , make 7 $ \a b c -> a <> (b <>- c) :==: (a <> b) <>- c - , make 8 $ \a b -> a <>- inverse b :==: a <> b - , make 9 $ \a b -> inverse (a <>- b) :==: inverse a <> b - ] - where - make n = law ("append-inverse-law" ++ show (n :: Int)) - --------------------------------------------------------- --- Abelian groups - -commutative :: Monoid a => Law a -commutative = commutativeFor (<>) - -inverseDistr :: Group a => Law a -inverseDistr = law "inverse-distr" $ \a b -> - inverse (a <> b) :==: (inverse a <> inverse b) - -abelianGroupLaws :: Group a => [Law a] -abelianGroupLaws = groupLaws ++ [commutative, inverseDistr] - --------------------------------------------------------- --- Monoids with a zero element --- This element could be the additive identity from a (semi-)ring for --- the multiplicative monoid - -leftZero :: MonoidZero a => Law a -leftZero = law "left-zero" $ \a -> mzero <> a :==: mzero - -rightZero:: MonoidZero a => Law a -rightZero = law "right-zero" $ \a -> a <> mzero :==: mzero - -zeroLaws :: MonoidZero a => [Law a] -zeroLaws = [leftZero, rightZero] - -monoidZeroLaws :: MonoidZero a => [Law a] -monoidZeroLaws = monoidLaws ++ zeroLaws - --------------------------------------------------------- --- Generalized laws - -associativeFor :: (a -> a -> a) -> Law a -associativeFor (?) = law "associative" $ \a b c -> - a ? (b ? c) :==: (a ? b) ? c - -commutativeFor :: (a -> a -> a) -> Law a -commutativeFor (?) = law "commutative" $ \a b -> a ? b :==: b ? a - -idempotentFor :: (a -> a -> a) -> Law a -idempotentFor (?) = law "idempotent" $ \a -> a ? a :==: a - -leftDistributiveFor :: (a -> a -> a) -> (a -> a -> a) -> Law a -leftDistributiveFor (<*>) (<+>) = law "left-distributive" $ \a b c -> - a <*> (b <+> c) :==: (a <*> b) <+> (a <*> c) - -rightDistributiveFor :: (a -> a -> a) -> (a -> a -> a) -> Law a -rightDistributiveFor (<*>) (<+>) = law "right-distributive" $ \a b c -> - (a <+> b) <*> c :==: (a <*> c) <+> (b <*> c) diff --git a/src/Ideas/Common/Algebra/Law.hs b/src/Ideas/Common/Algebra/Law.hs deleted file mode 100644 --- a/src/Ideas/Common/Algebra/Law.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ExistentialQuantification #-} ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Common.Algebra.Law - ( Law, LawSpec((:==:)), law, lawAbs, mapLaw - , propertyLaw, rewriteLaw - ) where - -import Ideas.Common.Rewriting -import Test.QuickCheck - -infix 1 :==: - -data Law a = Law String (LawSpec a) - -instance Show (Law a) where - show (Law s _) = s - -data LawSpec a - = AbsMono (a -> LawSpec a) -- simple abstraction (fewer classes needed) - | forall b . (Arbitrary b, Show b, Different b) => Abs (b -> LawSpec a) -- generalized abstraction - | a :==: a - -law :: LawBuilder l a => String -> l -> Law a -law s l = Law s (lawSpec l) - -lawAbs :: (Different b, Arbitrary b, Show b) => (b -> LawSpec a) -> LawSpec a -lawAbs = Abs - -class LawBuilder l a | l -> a where - lawSpec :: l -> LawSpec a - -instance LawBuilder (LawSpec a) a where - lawSpec = id - -instance LawBuilder (Law a) a where - lawSpec = getLawSpec - -instance LawBuilder b a => LawBuilder (a -> b) a where - lawSpec f = AbsMono (lawSpec . f) - -instance (Show a, Eq a, Arbitrary a) => Testable (Law a) where - property = propertyLaw (==) - -mapLaw :: (b -> a) -> (a -> b) -> Law a -> Law b -mapLaw to from (Law s l) = Law s (rec l) - where - rec (AbsMono f) = AbsMono (rec . f . to) - rec (Abs f) = Abs (rec . f) - rec (a :==: b) = from a :==: from b - -propertyLaw :: (Arbitrary a, Show a, Testable b) => (a -> a -> b) -> Law a -> Property -propertyLaw eq = rec . getLawSpec - where - rec (AbsMono f) = property (rec . f) - rec (Abs f) = property (rec . f) - rec (a :==: b) = property (eq a b) - -rewriteLaw :: (Different a, IsTerm a, Arbitrary a, Show a) => Law a -> RewriteRule a -rewriteLaw (Law s l) = makeRewriteRule s l - -instance (Arbitrary a, IsTerm a, Show a, Different a) => RuleBuilder (LawSpec a) a where - buildRuleSpec i (a :==: b) = buildRuleSpec i (a :~> b) - buildRuleSpec i (AbsMono f) = buildRuleSpec i f - buildRuleSpec i (Abs f) = buildRuleSpec i f - -getLawSpec :: Law a -> LawSpec a -getLawSpec (Law _ l) = l diff --git a/src/Ideas/Common/Algebra/SmartGroup.hs b/src/Ideas/Common/Algebra/SmartGroup.hs deleted file mode 100644 --- a/src/Ideas/Common/Algebra/SmartGroup.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-} ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Common.Algebra.SmartGroup - ( -- * Smart datatypes - Smart(..), SmartZero(..), SmartGroup(..) - --- * Smart field - , SmartField(..), (.+.), (.-.), neg, (.*.), (./.) - -- * Smart booleans - , (.&&.), (.||.) - ) where - -import Control.Applicative -import Control.Monad (mplus) -import Data.Maybe -import Ideas.Common.Algebra.Boolean -import Ideas.Common.Algebra.Field -import Ideas.Common.Algebra.Group - -newtype Smart a = Smart {fromSmart :: a} - deriving (Show, Eq, Ord, CoMonoid, MonoidZero, CoMonoidZero) - -instance Functor Smart where -- could be derived - fmap f = Smart . f . fromSmart - -instance Applicative Smart where - pure = Smart - Smart f <*> Smart a = Smart (f a) - -instance (CoMonoid a, Monoid a) => Monoid (Smart a) where - mempty = Smart mempty - mappend a b - | isEmpty a = b - | isEmpty b = a - | otherwise = liftA2 (<>) a b - --------------------------------------------------------------- - -newtype SmartZero a = SmartZero {fromSmartZero :: a} - deriving (Show, Eq, Ord, MonoidZero, CoMonoid, CoMonoidZero) - -instance Functor SmartZero where -- could be derived - fmap f = SmartZero . f . fromSmartZero - -instance Applicative SmartZero where - pure = SmartZero - SmartZero f <*> SmartZero a = SmartZero (f a) - -instance (CoMonoidZero a, MonoidZero a) => Monoid (SmartZero a) where - mempty = SmartZero mempty - mappend a b - | isMonoidZero a || isMonoidZero b = mzero - | otherwise = liftA2 (<>) a b - --------------------------------------------------------------- - -newtype SmartGroup a = SmartGroup {fromSmartGroup :: a} - deriving (Show, Eq, Ord, CoMonoid, CoGroup, CoMonoidZero, MonoidZero) - -instance Functor SmartGroup where -- could be derived - fmap f = SmartGroup . f . fromSmartGroup - -instance Applicative SmartGroup where - pure = SmartGroup - SmartGroup f <*> SmartGroup a = SmartGroup (f a) - -instance (CoGroup a, Group a) => Monoid (SmartGroup a) where - mempty = SmartGroup mempty - mappend a b - | isEmpty a = b - | otherwise = fromMaybe (liftA2 (<>) a b) (matchGroup alg b) - where - alg = (a, \x y -> (a <> x) <> y, \x -> a <>- x, \x y -> (a <> x) <>- y) - -instance (CoGroup a, Group a) => Group (SmartGroup a) where - inverse a = fromMaybe (liftA inverse a) (matchGroup alg a) - where - alg = (mempty, \x y -> inverse x <>- y, id, \x y -> inverse x <> y) - appendInv a b - | isEmpty a = inverse b - | otherwise = fromMaybe (liftA2 (<>-) a b) (matchGroup alg b) - where - alg = (a, \x y -> (a <>- x) <>- y, \x -> a <> x, \x y -> (a <>- x) <> y) - --------------------------------------------------------------- - -type GroupMatch a b = (b, a -> a -> b, a -> b, a -> a -> b) - -matchGroup :: CoGroup a => GroupMatch a b -> a -> Maybe b -matchGroup (emp, app, inv, appinv) a = - (if isEmpty a then Just emp else Nothing) `mplus` - fmap (uncurry app) (isAppend a) `mplus` - fmap inv (isInverse a) `mplus` - fmap (uncurry appinv) (isAppendInv a) - --------------------------------------------------------------- --- Smart Field - -newtype SmartField a = SmartField {fromSmartField :: a} - deriving (CoSemiRing, CoRing, CoField) - -instance Functor SmartField where -- could be derived - fmap f = SmartField . f . fromSmartField - -instance Applicative SmartField where - pure = SmartField - SmartField f <*> SmartField a = SmartField (f a) - -instance (CoField a, Field a) => SemiRing (SmartField a) where - zero = SmartField zero - one = SmartField one - SmartField a |+| SmartField b = SmartField $ fromAdditive $ fromSmartGroup $ - SmartGroup (Additive a) <> SmartGroup (Additive b) - a |*| b - | Just x <- isNegate a = plusInverse (x |*| b) - | Just x <- isNegate b = plusInverse (a |*| x) - | isZero a || isZero b = zero - | isOne a = b - | isOne b = a - | Just (x, y) <- isTimes b = (a |*| x) |*| y - | Just (x, y) <- isDivision b = (a |*| x) |/| y - | otherwise = liftA2 (|*|) a b - -instance (CoField a, Field a) => Ring (SmartField a) where - plusInverse = SmartField . fromAdditive . fromSmartGroup . inverse - . SmartGroup . Additive . fromSmartField - SmartField a |-| SmartField b = SmartField $ fromAdditive $ fromSmartGroup $ - SmartGroup (Additive a) <>- SmartGroup (Additive b) - -instance (CoField a, Field a) => Field (SmartField a) where - timesInverse a - | Just x <- isNegate a = plusInverse (timesInverse x) - | Just (x, y) <- isDivision a, isOne y = x - | otherwise = liftA timesInverse a - a |/| b - | Just x <- isNegate a = plusInverse (x |/| b) - | Just x <- isNegate b = plusInverse (a |/| x) - | isOne b = a - | Just (x, y) <- isDivision a = x |/| (y |*| b) - | otherwise = liftA2 (|/|) a b - ------------------------------------------------------------------- - -infixl 7 .*., ./. -infixl 6 .-., .+. - -(.+.) :: (CoField a, Field a) => a -> a -> a -a .+. b = fromSmartField $ SmartField a |+| SmartField b - -(.-.) :: (CoField a, Field a) => a -> a -> a -a .-. b = fromSmartField $ SmartField a |-| SmartField b - -neg :: (CoField a, Field a) => a -> a -neg = fromSmartField . plusInverse . SmartField - -(.*.) :: (CoField a, Field a) => a -> a -> a -a .*. b = fromSmartField $ SmartField a |*| SmartField b - -(./.) :: (CoField a, Field a) => a -> a -> a -a ./. b = fromSmartField $ SmartField a |/| SmartField b - --- myrecip :: (CoField a, Field a) => a -> a --- myrecip = fromSmartField . timesInverse . SmartField - --------------------------------------------------------------- --- Smart booleans - -instance BoolValue a => BoolValue (Smart a) where - fromBool = Smart . fromBool - isTrue = isTrue . fromSmart - isFalse = isFalse . fromSmart - -instance (Boolean a, CoBoolean a) => Boolean (Smart a) where - a <&&> b = fmap fromAnd $ fromSmartZero $ - SmartZero (fmap And a) <> SmartZero (fmap And b) - a <||> b = fmap fromOr $ fromSmartZero $ - SmartZero (fmap Or a) <> SmartZero (fmap Or b) - complement (Smart a) - | isTrue a = false - | isFalse a = true - | otherwise = Smart $ fromMaybe (complement a) (isComplement a) - -infixr 4 .||. -infixr 5 .&&. - -(.&&.), (.||.) :: (Boolean a, CoBoolean a) => a -> a -> a -a .&&. b = fromSmart $ Smart a <&&> Smart b -a .||. b = fromSmart $ Smart a <||> Smart b 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 @@ -23,6 +23,9 @@ , BiFunctor(biMap, mapFirst, mapSecond), mapBoth -- * Type class Fix , Fix(..) + -- * Boolean Algebra + , BoolValue(..), Boolean(..) + , ands, ors, implies, equivalent -- * Buggy and Minor properties , Buggy(..), Minor(..) ) where @@ -120,6 +123,60 @@ fix :: (a -> a) -> a -- default implementation fix f = let a = f a in a + +-------------------------------------------------------- +-- Boolean algebra + +-- Minimal complete definitions: (true/false, or fromBool) and isTrue/isFalse +class BoolValue a where + true :: a + false :: a + fromBool :: Bool -> a + isTrue :: a -> Bool + isFalse :: a -> Bool + -- default definitions + true = fromBool True + false = fromBool False + fromBool b = if b then true else false + +class BoolValue a => Boolean a where + (<&&>) :: a -> a -> a + (<||>) :: a -> a -> a + complement :: a -> a + +instance BoolValue Bool where + fromBool = id + isTrue = id + isFalse = not + +instance BoolValue b => BoolValue (a -> b) where + fromBool x = const (fromBool x) + isTrue = error "not implemented" + isFalse = error "not implemented" + +instance Boolean Bool where + (<&&>) = (&&) + (<||>) = (||) + complement = not + +instance Boolean b => Boolean (a -> b) where + f <&&> g = \x -> f x <&&> g x + f <||> g = \x -> f x <||> g x + complement = (.) complement + +ands :: Boolean a => [a] -> a -- or use mconcat with And monoid +ands xs | null xs = true + | otherwise = foldr1 (<&&>) xs + +ors :: Boolean a => [a] -> a +ors xs | null xs = false + | otherwise = foldr1 (<||>) xs + +implies :: Boolean a => a -> a -> a +implies a b = complement a <||> b + +equivalent :: Boolean a => a -> a -> a +equivalent a b = (a <&&> b) <||> (complement a <&&> complement b) ----------------------------------------------------------- -- Buggy and Minor properties 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 @@ -29,15 +29,14 @@ , currentTerm, changeTerm, replaceInContext, currentInContext, changeInContext ) where -import Control.Monad import Data.Maybe import Ideas.Common.Environment import Ideas.Common.Id import Ideas.Common.Rewriting import Ideas.Common.Traversal.Navigator import Ideas.Common.Traversal.Utils -import Ideas.Common.Utils.Uniplate import Ideas.Common.View hiding (left, right) +import Ideas.Utils.Uniplate ---------------------------------------------------------- -- Abstract data type @@ -53,13 +52,13 @@ currentNavigator . getNavigator . top fromContextWith :: Monad m => (a -> b) -> Context a -> m b -fromContextWith f = liftM f . fromContext +fromContextWith f = fmap f . fromContext fromContextWith2 :: Monad m => (a -> b -> c) -> Context a -> Context b -> m c -fromContextWith2 f a b = liftM2 f (fromContext a) (fromContext b) +fromContextWith2 f a b = f <$> fromContext a <*> fromContext b instance Eq a => Eq (Context a) where - x == y = fromMaybe False $ liftM2 (==) (fromContext x) (fromContext y) + x == y = fromMaybe False $ (==) <$> fromContext x <*> fromContext y instance Show a => Show (Context a) where show c@(C env a) = @@ -103,8 +102,8 @@ liftCN :: Monad m => (forall b . Navigator b => b -> m b) -> Context a -> m (Context a) -liftCN f (C env (TermNav a)) = liftM (C env . TermNav) (f a) -liftCN f (C env (Simple a)) = liftM (C env . Simple) (f a) +liftCN f (C env (TermNav a)) = (C env . TermNav) <$> f a +liftCN f (C env (Simple a)) = (C env . Simple) <$> f a liftCN _ (C _ (NoNav _)) = fail "noNavigator" navLocation :: ContextNavigator a -> Location @@ -127,7 +126,7 @@ currentT _ = Nothing changeT :: (Term -> Maybe Term) -> ContextNavigator a -> Maybe (ContextNavigator a) -changeT f (TermNav a) = fmap TermNav (changeM f a) +changeT f (TermNav a) = TermNav <$> changeM f a changeT _ _ = Nothing castT :: IsTerm b => ContextNavigator a -> Maybe (ContextNavigator b) @@ -160,7 +159,7 @@ useC = liftViewIn (makeView f g) where f old@(C env a) = castT a >>= \b -> return (C env b, old) - g (C env a, old) = fromMaybe old (liftM (C env) (castT a)) + g (C env a, old) = fromMaybe old (C env <$> castT a) currentTerm :: Context a -> Maybe Term currentTerm = currentT . getNavigator diff --git a/src/Ideas/Common/CyclicTree.hs b/src/Ideas/Common/CyclicTree.hs deleted file mode 100644 --- a/src/Ideas/Common/CyclicTree.hs +++ /dev/null @@ -1,218 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Common.CyclicTree - ( -- * Data type - CyclicTree - -- * Constructor functions - , node, node0, node1, node2, leaf, label - -- * Querying - , isNode, isLeaf, isLabel - -- * Replace functions - , replaceNode, replaceLeaf, replaceLabel, shrinkTree - -- * Fold and algebra - , fold, foldUnwind - , CyclicTreeAlg, fNode, fLeaf, fLabel, fRec, fVar - , emptyAlg, monoidAlg - ) where - -import Control.Applicative -import Control.Monad -import Data.List (intercalate) -import Ideas.Common.Classes -import Ideas.Common.Id -import Test.QuickCheck hiding (label) - --------------------------------------------------------------- --- Data type - -data CyclicTree a b - = Node a [CyclicTree a b] - | Leaf b - | Label Id (CyclicTree a b) - | Rec Int (CyclicTree a b) - | Var Int - -instance (Show a, Show b) => Show (CyclicTree a b) where - show = fold Alg - { fNode = \a xs -> show a ++ par xs - , fLeaf = show - , fLabel = \l s -> show l ++ ":" ++ s - , fRec = \n s -> '#' : show n ++ "=" ++ s - , fVar = \n -> '#' : show n - } - -instance BiFunctor CyclicTree where - biMap f g = fold idAlg {fNode = Node . f, fLeaf = Leaf . g} - -instance Functor (CyclicTree d) where - fmap = mapSecond - -instance Applicative (CyclicTree d) where - pure = leaf - p <*> q = fold idAlg {fLeaf = (`fmap` q)} p - -instance Monad (CyclicTree d) where - return = leaf - (>>=) = flip replaceLeaf - -instance Foldable (CyclicTree d) where - foldMap f = fold monoidAlg {fLeaf = f} - -instance Traversable (CyclicTree d) where - traverse f = fold emptyAlg - { fNode = \a -> liftA (node a) . sequenceA - , fLeaf = liftA leaf . f - , fLabel = liftA . label - , fRec = liftA . Rec - , fVar = pure . Var - } - -instance Fix (CyclicTree a b) where - fix f = Rec n (f (Var n)) - where - vs = vars (f (Var (-1))) - n = maximum (-1 : vs) + 1 - -instance (Arbitrary a, Arbitrary b) => Arbitrary (CyclicTree a b) where - arbitrary = sized arbTree - shrink = shrinkTree - -arbTree :: (Arbitrary a, Arbitrary b) => Int -> Gen (CyclicTree a b) -arbTree = rec 0 - where - rec vi 0 = frequency $ - (3, liftM leaf arbitrary) - : [ (1, elements (map Var [1..vi])) | vi > 0 ] - rec vi n = frequency - [ (3, liftM2 node arbitrary ms) - , (2, rec vi 0) - , (1, liftM2 label genId m) - , (1, liftM (Rec (vi+1)) (rec (vi+1) (n `div` 2))) - ] - where - m = rec vi (n `div` 2) - genId = elements [ newId [c] | c <- ['A' .. 'Z']] - ms = choose (0, 3) >>= \i -> replicateM i m - -shrinkTree :: CyclicTree a b -> [CyclicTree a b] -shrinkTree tree = - case tree of - Node a ts -> ts ++ map (node a) (shrinkTrees ts) - Label l t -> t : map (Label l) (shrinkTree t) - Rec n t -> map (Rec n) (shrinkTree t) - _ -> [] - --- shrink exactly one tree -shrinkTrees :: [CyclicTree a b] -> [[CyclicTree a b]] -shrinkTrees [] = [] -shrinkTrees (t:ts) = map (:ts) (shrinkTree t) ++ map (t:) (shrinkTrees ts) - --- local helpers -par :: [String] -> String -par xs | null xs = "" - | otherwise = "(" ++ intercalate ", " xs ++ ")" - -vars :: CyclicTree a b -> [Int] -vars = fold monoidAlg {fVar = return} - --------------------------------------------------------------- --- Constructor functions - -node :: a -> [CyclicTree a b] -> CyclicTree a b -node = Node - -node0 :: a -> CyclicTree a b -node0 a = node a [] - -node1 :: a -> CyclicTree a b -> CyclicTree a b -node1 a x = node a [x] - -node2 :: a -> CyclicTree a b -> CyclicTree a b -> CyclicTree a b -node2 a x y = node a [x, y] - -leaf :: b -> CyclicTree a b -leaf = Leaf - -label :: IsId n => n -> CyclicTree a b -> CyclicTree a b -label = Label . newId - --------------------------------------------------------------- --- Querying - -isNode :: CyclicTree a b -> Maybe (a, [CyclicTree a b]) -isNode (Node a xs) = Just (a, xs) -isNode _ = Nothing - -isLeaf :: CyclicTree a b -> Maybe b -isLeaf (Leaf b) = Just b -isLeaf _ = Nothing - -isLabel :: CyclicTree a b -> Maybe (Id, CyclicTree a b) -isLabel (Label l t) = Just (l, t) -isLabel _ = Nothing - --------------------------------------------------------------- --- Replace functions - -replaceNode :: (a -> [CyclicTree a b] -> CyclicTree a b) -> CyclicTree a b -> CyclicTree a b -replaceNode f = fold idAlg {fNode = f} - -replaceLabel :: (Id -> CyclicTree a b -> CyclicTree a b) -> CyclicTree a b -> CyclicTree a b -replaceLabel f = fold idAlg {fLabel = f} - -replaceLeaf :: (b -> CyclicTree a c) -> CyclicTree a b -> CyclicTree a c -replaceLeaf f = fold idAlg {fLeaf = f} - --------------------------------------------------------------- --- Fold and algebra - -fold :: CyclicTreeAlg a b t -> CyclicTree a b -> t -fold alg = rec - where - rec (Node a ts) = fNode alg a (map rec ts) - rec (Leaf b) = fLeaf alg b - rec (Label l t) = fLabel alg l (rec t) - rec (Rec n t) = fRec alg n (rec t) - rec (Var n) = fVar alg n - -foldUnwind :: CyclicTreeAlg a b t -> CyclicTree a b -> t -foldUnwind alg = start . fold Alg - { fNode = \a fs sub -> fNode alg a (map ($ sub) fs) - , fLeaf = \b _ -> fLeaf alg b - , fLabel = \l f sub -> fLabel alg l (f sub) - , fRec = \n f sub -> let this = f (extend n this sub) - in this - , fVar = \n sub -> sub n - } - where - start f = f (error "foldUnwind: unbound var") - extend n a sub i - | i == n = a - | otherwise = sub i - -data CyclicTreeAlg a b t = Alg - { fNode :: a -> [t] -> t - , fLeaf :: b -> t - , fLabel :: Id -> t -> t - , fRec :: Int -> t -> t - , fVar :: Int -> t - } - -idAlg :: CyclicTreeAlg a b (CyclicTree a b) -idAlg = Alg Node Leaf Label Rec Var - -emptyAlg :: CyclicTreeAlg a b t -emptyAlg = let f = error "emptyAlg: uninitialized" in Alg f f f f f - -monoidAlg :: Monoid m => CyclicTreeAlg a b m -monoidAlg = Alg (const mconcat) mempty (const id) (const id) mempty 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 @@ -15,7 +15,7 @@ module Ideas.Common.Environment ( -- * Reference - Ref, Reference(..) + Ref, Reference(..), mapRef -- * Binding , Binding, makeBinding , fromBinding, showValue, getTermValue @@ -28,11 +28,11 @@ import Control.Monad import Data.Function import Data.List -import Data.Typeable import Ideas.Common.Id import Ideas.Common.Rewriting.Term -import Ideas.Common.Utils import Ideas.Common.View +import Ideas.Utils.Prelude +import Ideas.Utils.Typeable import qualified Data.Map as M ----------------------------------------------------------- @@ -40,10 +40,11 @@ -- | A data type for references (without a value) data Ref a = Ref - { identifier :: Id -- ^ Identifier - , printer :: a -> String -- ^ A pretty-printer - , parser :: String -> Maybe a -- ^ A parser - , refView :: View Term a -- ^ Conversion to/from term + { identifier :: Id -- Identifier + , printer :: a -> String -- Pretty-printer + , parser :: String -> Maybe a -- Parser + , refView :: View Term a -- Conversion to/from term + , refType :: IsTypeable a } instance Show (Ref a) where @@ -56,20 +57,23 @@ getId = identifier changeId f d = d {identifier = f (identifier d)} +instance HasTypeable Ref where + getTypeable = Just . refType + -- | A type class for types as references class (IsTerm a, Typeable a, Show a, Read a) => Reference a where makeRef :: IsId n => n -> Ref a makeRefList :: IsId n => n -> Ref [a] -- default implementation - makeRef n = Ref (newId n) show readM termView - makeRefList n = Ref (newId n) show readM termView + makeRef n = Ref (newId n) show readM termView typeable + makeRefList n = Ref (newId n) show readM termView typeable instance Reference Int instance Reference Term instance Reference Char where - makeRefList n = Ref (newId n) id Just variableView + makeRefList n = Ref (newId n) id Just variableView typeable instance Reference ShowString @@ -78,33 +82,41 @@ instance (Reference a, Reference b) => Reference (a, b) +mapRef :: Typeable b => Isomorphism a b -> Ref a -> Ref b +mapRef iso r = r + { printer = printer r . to iso + , parser = fmap (from iso) . parser r + , refView = refView r >>> toView iso + , refType = typeable + } + ----------------------------------------------------------- -- Binding -data Binding = forall a . Typeable a => Binding (Ref a) a +data Binding = forall a . Binding (Ref a) a instance Show Binding where show a = showId a ++ "=" ++ showValue a instance Eq Binding where - (==) = let f (Binding ref a) = (getId ref, build (refView ref) a) + (==) = let f (Binding r a) = (getId r, build (refView r) a) in (==) `on` f instance HasId Binding where - getId (Binding ref _ ) = getId ref - changeId f (Binding ref a) = Binding (changeId f ref) a + getId (Binding r _ ) = getId r + changeId f (Binding r a) = Binding (changeId f r) a -makeBinding :: Typeable a => Ref a -> a -> Binding +makeBinding :: Ref a -> a -> Binding makeBinding = Binding fromBinding :: Typeable a => Binding -> Maybe (Ref a, a) -fromBinding (Binding ref a) = liftM2 (,) (gcast ref) (cast a) +fromBinding (Binding r a) = liftM2 (,) (gcastFrom r r) (castFrom r a) showValue :: Binding -> String -showValue (Binding ref a) = printer ref a +showValue (Binding r a) = printer r a getTermValue :: Binding -> Term -getTermValue (Binding ref a) = build (refView ref) a +getTermValue (Binding r a) = build (refView r) a ----------------------------------------------------------- -- Heterogeneous environment @@ -125,22 +137,22 @@ makeEnvironment :: [Binding] -> Environment makeEnvironment xs = Env $ M.fromList [ (getId a, a) | a <- xs ] -singleBinding :: Typeable a => Ref a -> a -> Environment -singleBinding ref = makeEnvironment . return . Binding ref +singleBinding :: Ref a -> a -> Environment +singleBinding r = makeEnvironment . return . Binding r class HasEnvironment env where environment :: env -> Environment setEnvironment :: Environment -> env -> env deleteRef :: Ref a -> env -> env - insertRef :: Typeable a => Ref a -> a -> env -> env - changeRef :: Typeable a => Ref a -> (a -> a) -> env -> env + insertRef :: Ref a -> a -> env -> env + changeRef :: Ref a -> (a -> a) -> env -> env -- default definitions deleteRef a = changeEnv (Env . M.delete (getId a) . envMap) - insertRef ref = + insertRef r = let f b = Env . M.insert (getId b) b . envMap - in changeEnv . f . Binding ref - changeRef ref f env = - maybe id (insertRef ref . f) (ref ? env) env + in changeEnv . f . Binding r + changeRef r f env = + maybe id (insertRef r . f) (r ? env) env -- local helper changeEnv :: HasEnvironment env => (Environment -> Environment) -> env -> env @@ -168,11 +180,11 @@ noBindings :: HasEnvironment env => env -> Bool noBindings = M.null . envMap . environment -(?) :: (HasEnvironment env, Typeable a) => Ref a -> env -> Maybe a +(?) :: HasEnvironment env => Ref a -> env -> Maybe a ref ? env = do let m = envMap (environment env) - Binding _ a <- M.lookup (getId ref) m - msum [ cast a -- typed value - , cast a >>= parser ref -- value as string - , cast a >>= match (refView ref) -- value as term + Binding r a <- M.lookup (getId ref) m + msum [ castBetween r ref a -- typed value + , castFrom r a >>= parser ref -- value as string + , castFrom r a >>= match (refView ref) -- value as term ] 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,4 +1,4 @@ -{-# LANGUAGE Rank2Types, DeriveDataTypeable #-} +{-# LANGUAGE Rank2Types, ExistentialQuantification #-} ----------------------------------------------------------------------------- -- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -32,7 +32,7 @@ -- * Type casting , useTypeable, castFrom, castTo -- * Exercise properties - , setProperty, getProperty + , setProperty, getProperty, setPropertyF, getPropertyF -- * Random generators , simpleGenerator, useGenerator, randomTerm, randomTerms -- * Derivations @@ -41,8 +41,6 @@ ) where import Data.Char -import Data.Data -import Data.Dynamic import Data.List import Data.Maybe import Data.Ord @@ -55,8 +53,9 @@ import Ideas.Common.Rewriting import Ideas.Common.Rule import Ideas.Common.Strategy hiding (not, fail, repeat, replicate) -import Ideas.Common.Utils (ShowString(..)) import Ideas.Common.View +import Ideas.Utils.Prelude (ShowString(..)) +import Ideas.Utils.Typeable import System.Random import Test.QuickCheck hiding (label) import Test.QuickCheck.Gen @@ -129,7 +128,7 @@ , hasTypeable :: Maybe (IsTypeable a) -- | Extra exercise-specific properties, not used by the default -- feedback services. - , properties :: M.Map String Dynamic -- extra, domain-specific properties + , properties :: M.Map Id (Dynamic a) -- extra, domain-specific properties } instance Eq (Exercise a) where @@ -202,7 +201,7 @@ -- | Returns a sorted list of rules, without duplicates. ruleset :: Exercise a -> [Rule (Context a)] -ruleset ex = nub (sortBy compareId list) +ruleset ex = nub (sortBy (ruleOrdering ex) list) where list = extraRules ex ++ rulesInStrategy (strategy ex) @@ -252,7 +251,7 @@ type Examples a = [(Difficulty, a)] data Difficulty = VeryEasy | Easy | Medium | Difficult | VeryDifficult - deriving (Eq, Ord, Enum, Data, Typeable) + deriving (Eq, Ord, Enum) instance Show Difficulty where show = (xs !!) . fromEnum @@ -310,38 +309,55 @@ ----------------------------------------------------------------------------- -- Type casting -data IsTypeable a = IT (forall b . Typeable b => a -> Maybe b) - (forall b . Typeable b => b -> Maybe a) +instance HasTypeable Exercise where + getTypeable = hasTypeable -- | Encapsulates a type representation (use for 'hasTypeable' field). useTypeable :: Typeable a => Maybe (IsTypeable a) -useTypeable = Just (IT cast cast) - --- | Cast from polymorphic type (to exercise-specific type). --- This only works if 'hasTypeable' contains the right type representation. -castFrom :: Typeable b => Exercise a -> a -> Maybe b -castFrom ex a = do - IT f _ <- hasTypeable ex - f a - --- | Cast to polymorphic type (from exercise-specific type). --- This only works if 'hasTypeable' contains the right type representation. -castTo :: Typeable b => Exercise a -> b -> Maybe a -castTo ex a = do - IT _ g <- hasTypeable ex - g a +useTypeable = Just typeable ----------------------------------------------------------------------------- -- Exercise-specific properties -- | Set an exercise-specific property (with a dynamic type) -setProperty :: Typeable val => String -> val -> Exercise a -> Exercise a -setProperty key a ex = - ex { properties = M.insert key (toDyn a) (properties ex) } +setProperty :: (IsId n, Typeable val) => n -> val -> Exercise a -> Exercise a +setProperty key a = insertProperty key (Dyn (cast a)) +-- | Set an exercise-specific property (with a dynamic type) that is +-- parameterized over the exercise term. +setPropertyF :: (IsId n, Typeable f) => n -> f a -> Exercise a -> Exercise a +setPropertyF key a = insertProperty key (DynF (castF a)) + +insertProperty :: IsId n => n -> Dynamic a -> Exercise a -> Exercise a +insertProperty key d ex = + ex { properties = M.insert (newId key) d (properties ex) } + -- | Get an exercise-specific property (of a dynamic type) -getProperty :: Typeable val => String -> Exercise a -> Maybe val -getProperty key ex = M.lookup key (properties ex) >>= fromDynamic +getProperty :: (IsId n, Typeable val) => n -> Exercise a -> Maybe val +getProperty key ex = lookupProperty key ex >>= \d -> + case d of + Dyn m -> m + _ -> Nothing + +-- | Get an exercise-specific property (of a dynamic type) that is +-- parameterized over the exercise term. +getPropertyF :: (IsId n, Typeable f) => n -> Exercise a -> Maybe (f a) +getPropertyF key ex = lookupProperty key ex >>= \d -> + case d of + DynF m -> m + _ -> Nothing + +lookupProperty :: IsId n => n -> Exercise a -> Maybe (Dynamic a) +lookupProperty key = M.lookup (newId key) . properties + +-- | Values with a dynamic type that is parameterized over the exercise term. +data Dynamic a = Dyn (forall b . Typeable b => Maybe b) + | DynF (forall f . Typeable f => Maybe (f a)) + +castF :: (Typeable f, Typeable g) => f a -> Maybe (g a) +castF = fmap fromIdentity . gcast1 . Identity + +newtype Identity a = Identity { fromIdentity :: a} --------------------------------------------------------------- -- Random generators 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 @@ -23,8 +23,8 @@ import Ideas.Common.Exercise import Ideas.Common.Id import Ideas.Common.Rule -import Ideas.Common.Utils.TestSuite import Ideas.Common.View +import Ideas.Utils.TestSuite import Test.QuickCheck import Test.QuickCheck.Random @@ -54,7 +54,7 @@ checkParserPrettyEx ex . inContext ex . fromS , suite "Soundness non-buggy rules" $ let eq a b = equivalence ex (fromS a) (fromS b) - myGen = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen) + myGen = showAs (prettyPrinterContext ex) (inContext ex <$> gen) myView = makeView (Just . fromS) (S (prettyPrinterContext ex)) args = stdArgs {maxSize = 10, maxSuccess = 10} in [ usePropertyWith (showId r) args $ @@ -81,7 +81,7 @@ show a = showS a (fromS a) showAs :: (a -> String) -> Gen a -> Gen (ShowAs a) -showAs f = liftM (S f) +showAs f = fmap (S f) -- check combination of parser and pretty-printer checkParserPretty :: (a -> a -> Bool) -> (String -> Either String a) -> (a -> String) -> a -> Bool 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,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -45,13 +44,12 @@ import Control.Monad import Data.Char -import Data.Data import Data.List import Data.Monoid import Data.Ord import Ideas.Common.Classes -import Ideas.Common.Utils (splitsWithElem) -import Ideas.Common.Utils.StringRef +import Ideas.Utils.Prelude (splitsWithElem) +import Ideas.Utils.StringRef import Test.QuickCheck --------------------------------------------------------------------- @@ -64,7 +62,6 @@ , idDescription :: String , idRef :: !StringRef } - deriving (Data, Typeable) instance Show Id where show = intercalate "." . idList 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 @@ -15,6 +15,7 @@ module Ideas.Common.Library ( module Export , failS, notS, repeatS, replicateS, sequenceS, untilS + , Some(..) ) where import Ideas.Common.Classes as Export @@ -28,8 +29,8 @@ import Ideas.Common.Rule as Export import Ideas.Common.Strategy as Export hiding (fail, not, repeat, replicate, sequence, until) import Ideas.Common.Traversal.Navigator as Export (Location, location, toLocation, fromLocation, arity, top) -import Ideas.Common.Utils as Export (readM) import Ideas.Common.View as Export +import Ideas.Utils.Prelude as Export (readM, Some(..)) import qualified Ideas.Common.Strategy as S 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 @@ -22,7 +22,7 @@ , ands, ors, implies, equivalent ) where -import Ideas.Common.Algebra.Boolean +import Ideas.Common.Classes import Ideas.Common.Id import Ideas.Common.View 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 @@ -24,7 +24,7 @@ import Ideas.Common.Rewriting.Unification import Ideas.Common.Traversal.Navigator import Ideas.Common.Traversal.Utils -import Ideas.Common.Utils.Uniplate hiding (rewriteM) +import Ideas.Utils.Uniplate hiding (rewriteM) normalForm :: [RewriteRule a] -> Term -> Term normalForm rs = run [] 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 @@ -32,8 +32,8 @@ import Ideas.Common.Rewriting.Substitution import Ideas.Common.Rewriting.Term import Ideas.Common.Rewriting.Unification -import Ideas.Common.Utils.Uniplate (descend) import Ideas.Common.View hiding (match) +import Ideas.Utils.Uniplate (descend) import qualified Data.IntSet as IS import qualified Data.Map as M 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 @@ -22,8 +22,8 @@ import Data.List import Data.Maybe import Ideas.Common.Rewriting.Term -import Ideas.Common.Utils.TestSuite -import Ideas.Common.Utils.Uniplate +import Ideas.Utils.TestSuite +import Ideas.Utils.Uniplate import Test.QuickCheck import qualified Data.IntMap as IM import qualified Data.IntSet as IS @@ -91,7 +91,7 @@ infix 6 @+@ (@+@) :: Substitution -> Substitution -> Maybe Substitution -s1 @+@ s2 = liftM S $ foldM op (unS s1) $ IM.toList $ unS s2 +s1 @+@ s2 = fmap S $ foldM op (unS s1) $ IM.toList $ unS s2 where op m (i, a) = case IM.lookup i m of 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,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- Copyright 2016, Ideas project team. This file is distributed under the @@ -18,6 +17,7 @@ ( -- * Symbols Symbol, newSymbol , isAssociative, makeAssociative + , nothingSymbol, trueSymbol, falseSymbol -- * Terms , Term(..), IsTerm(..), termView , fromTermM, fromTermWith @@ -34,15 +34,15 @@ ) where import Control.Monad -import Data.Data import Data.Function import Data.Maybe import Ideas.Common.Id -import Ideas.Common.Utils (ShowString(..)) -import Ideas.Common.Utils.QuickCheck -import Ideas.Common.Utils.Uniplate import Ideas.Common.View +import Ideas.Utils.Prelude (ShowString(..)) +import Ideas.Utils.QuickCheck +import Ideas.Utils.Uniplate import qualified Data.IntSet as IS +import qualified Data.Map as M import qualified Data.Set as S ----------------------------------------------------------- @@ -84,7 +84,7 @@ | TNum Integer | TFloat Double | TMeta Int - deriving (Show, Read, Eq, Ord, Typeable) + deriving (Show, Read, Eq, Ord) instance Uniplate Term where uniplate (TCon x xs) = plate (function x) ||* xs @@ -95,8 +95,14 @@ -- * Type class for conversion to/from terms class IsTerm a where - toTerm :: a -> Term - fromTerm :: MonadPlus m => Term -> m a + toTerm :: a -> Term + toTermList :: [a] -> Term + fromTerm :: MonadPlus m => Term -> m a + fromTermList :: MonadPlus m => Term -> m [a] + -- default implementation + toTermList = TList . map toTerm + fromTermList (TList xs) = mapM fromTerm xs + fromTermList _ = fail "fromTermList: not a list" termView :: IsTerm a => View Term a termView = makeView fromTerm toTerm @@ -112,18 +118,18 @@ instance (IsTerm a, IsTerm b) => IsTerm (a, b) where toTerm (a, b) = TList [toTerm a, toTerm b] - fromTerm (TList [a, b]) = liftM2 (,) (fromTerm a) (fromTerm b) + fromTerm (TList [a, b]) = (,) <$> fromTerm a <*> fromTerm b fromTerm _ = fail "fromTerm" instance (IsTerm a, IsTerm b) => IsTerm (Either a b) where toTerm = either toTerm toTerm fromTerm expr = - liftM Left (fromTerm expr) `mplus` - liftM Right (fromTerm expr) + fmap Left (fromTerm expr) `mplus` + fmap Right (fromTerm expr) instance IsTerm Int where toTerm = TNum . fromIntegral - fromTerm = liftM fromInteger . fromTerm + fromTerm = fmap fromInteger . fromTerm instance IsTerm Integer where toTerm = TNum @@ -137,13 +143,41 @@ instance IsTerm Char where toTerm c = TVar [c] - fromTerm (TVar [c]) = return c - fromTerm _ = fail "fromTerm" + toTermList = TVar + fromTerm (TVar [c]) = return c + fromTerm _ = fail "fromTerm: not a TVar" + fromTermList (TVar s) = return s + fromTermList _ = fail "fromTermList: not a TVar" +instance IsTerm Bool where + toTerm True = symbol trueSymbol + toTerm False = symbol falseSymbol + fromTerm (TCon s []) + | s == trueSymbol = return True + | s == falseSymbol = return False + fromTerm _ = fail "fromTerm: not a Bool" + instance IsTerm a => IsTerm [a] where - toTerm = TList . map toTerm - fromTerm (TList xs) = mapM fromTerm xs - fromTerm _ = fail "fromTerm" + toTerm = toTermList + fromTerm = fromTermList + +instance (IsTerm a, Ord a) => IsTerm (S.Set a) where + toTerm = toTerm . S.toList + fromTerm = fmap S.fromList . fromTerm + +instance (IsTerm a, IsTerm b, Ord a) => IsTerm (M.Map a b) where + toTerm = toTerm . M.toList + fromTerm = fmap M.fromList . fromTerm + +trueSymbol, falseSymbol, nothingSymbol :: Symbol +trueSymbol = newSymbol "true" +falseSymbol = newSymbol "false" +nothingSymbol = newSymbol "Nothing" + +instance IsTerm a => IsTerm (Maybe a) where + toTerm = maybe (symbol nothingSymbol) toTerm + fromTerm (TCon s []) | s == nothingSymbol = return Nothing + fromTerm t = fmap Just (fromTerm t) fromTermM :: (Monad m, IsTerm a) => Term -> m a fromTermM = maybe (fail "fromTermM") return . fromTerm 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 @@ -21,7 +21,7 @@ import Ideas.Common.Rewriting.AC (pairingsMatchA) import Ideas.Common.Rewriting.Substitution import Ideas.Common.Rewriting.Term -import Ideas.Common.Utils.TestSuite +import Ideas.Utils.TestSuite import qualified Data.Map as M ----------------------------------------------------------- @@ -141,7 +141,7 @@ safeZipWith f = rec where rec [] [] = Just [] - rec (a:as) (b:bs) = liftM (f a b:) (rec as bs) + rec (a:as) (b:bs) = fmap (f a b:) (rec as bs) rec _ _ = Nothing products :: [[Substitution]] -> [Substitution] 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 @@ -13,7 +13,6 @@ module Ideas.Common.Rule (module Export) where import Ideas.Common.Rule.Abstract as Export -import Ideas.Common.Rule.EnvironmentMonad as Export import Ideas.Common.Rule.Parameter as Export import Ideas.Common.Rule.Recognizer as Export import Ideas.Common.Rule.Transformation as Export 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 @@ -25,10 +25,10 @@ , idRule, checkRule, emptyRule -- * Rule properties , ruleSiblings, siblingOf - , isRewriteRule, isRecognizer, doAfter + , isRewriteRule, doAfter -- * Recognizer , addRecognizer, addRecognizerBool - , addTransRecognizer, addRecognizerEnvMonad + , addTransRecognizer ) where import Control.Arrow @@ -37,7 +37,6 @@ import Ideas.Common.Environment import Ideas.Common.Id import Ideas.Common.Rewriting -import Ideas.Common.Rule.EnvironmentMonad import Ideas.Common.Rule.Recognizer import Ideas.Common.Rule.Transformation import Ideas.Common.View @@ -155,9 +154,6 @@ isRewriteRule :: Rule a -> Bool isRewriteRule = not . null . getRewriteRules . transformation -isRecognizer :: Rule a -> Bool -isRecognizer = isZeroTrans . transformation - siblingOf :: HasId b => b -> Rule a -> Rule a siblingOf sib r = r { ruleSiblings = getId sib : ruleSiblings r } @@ -173,9 +169,6 @@ addRecognizerBool :: (a -> a -> Bool) -> Rule a -> Rule a addRecognizerBool eq = addRecognizer (makeRecognizer eq) - -addRecognizerEnvMonad :: (a -> a -> EnvMonad ()) -> Rule a -> Rule a -addRecognizerEnvMonad = addRecognizer . makeRecognizerEnvMonad addTransRecognizer :: (a -> a -> Bool) -> Rule a -> Rule a addTransRecognizer eq r = flip addRecognizer r $ diff --git a/src/Ideas/Common/Rule/EnvironmentMonad.hs b/src/Ideas/Common/Rule/EnvironmentMonad.hs deleted file mode 100644 --- a/src/Ideas/Common/Rule/EnvironmentMonad.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- State monad for environments --- ------------------------------------------------------------------------------ - -module Ideas.Common.Rule.EnvironmentMonad - ( -- * Environment Monad - EnvMonad((:=), (:~), (:?)) - , getRef, updateRefs - -- * Running the monad - , runEnvMonad, execEnvMonad, evalEnvMonad - -- * Extracting used references - , envMonadRefs, envMonadFunctionRefs - ) where - -import Control.Applicative (Alternative(..)) -import Control.Monad -import Data.Maybe -import Data.Typeable -import Ideas.Common.Environment -import Ideas.Common.Utils -import System.IO.Unsafe -import qualified Control.Exception as C - ------------------------------------------------------------ --- Environment Monad - -infix 2 :=, :~, :? - -data EnvMonad a where - -- Monad operations - Return :: a -> EnvMonad a - Bind :: EnvMonad a -> (a -> EnvMonad b) -> EnvMonad b - Then :: EnvMonad a -> EnvMonad b -> EnvMonad b - Fail :: String -> EnvMonad b - -- MonadPlus operations - Zero :: EnvMonad a - Plus :: EnvMonad a -> EnvMonad a -> EnvMonad a - -- References (special) - (:=) :: Typeable a => Ref a -> a -> EnvMonad () - (:~) :: Typeable a => Ref a -> (a -> a) -> EnvMonad () - (:?) :: Typeable a => Ref a -> a -> EnvMonad a - GetRef :: Typeable a => Ref a -> EnvMonad a - -instance Functor EnvMonad where - fmap = liftM - -instance Applicative EnvMonad where - pure = return - (<*>) = ap - -instance Alternative EnvMonad where - empty = Zero - (<|>) = Plus - -instance Monad EnvMonad where - return = Return - (>>=) = Bind - fail = Fail - -instance MonadPlus EnvMonad where - mzero = Zero - mplus = Plus - -getRef :: Typeable a => Ref a -> EnvMonad a -getRef = GetRef - -updateRefs :: MonadPlus m => [EnvMonad a] -> Environment -> m Environment -updateRefs xs = msum . map return . execEnvMonad (sequence_ xs) - ------------------------------------------------------------ --- Environment Monad - -runEnvMonad :: EnvMonad a -> Environment -> [(a, Environment)] -runEnvMonad envMonad env = - case envMonad of - Return a -> [(a, env)] - Bind m f -> concat [ runEnvMonad (f a) e | (a, e) <- runEnvMonad m env ] - Then m n -> concat [ runEnvMonad n e | (_, e) <- runEnvMonad m env ] - Fail _ -> [] - Zero -> [] - Plus m n -> runEnvMonad m env ++ runEnvMonad n env - ref := a -> [((), insertRef ref a env)] - ref :~ f -> [((), changeRef ref f env)] - ref :? a -> [(fromMaybe a (ref ? env), env)] - GetRef ref -> case ref ? env of - Just a -> [(a, env)] - Nothing -> [] - -execEnvMonad :: EnvMonad a -> Environment -> [Environment] -execEnvMonad m = liftM snd . runEnvMonad m - -evalEnvMonad :: EnvMonad a -> Environment -> [a] -evalEnvMonad m = liftM fst . runEnvMonad m - ------------------------------------------------------------ --- Extracting used references - -envMonadRefs :: EnvMonad a -> [Some Ref] -envMonadRefs = unsafePerformIO . safeIO . envMonadRefsIO - -envMonadFunctionRefs :: (a -> EnvMonad b) -> [Some Ref] -envMonadFunctionRefs = unsafePerformIO . safeIO . envMonadFunctionRefsIO - -envMonadRefsIO :: EnvMonad a -> IO [Some Ref] -envMonadRefsIO monad = - case monad of - Bind m f -> envMonadRefsIO m ++++ envMonadFunctionRefsIO f - Then a b -> envMonadRefsIO a ++++ envMonadRefsIO b - Plus a b -> envMonadRefsIO a ++++ envMonadRefsIO b - r := _ -> return [Some r] - r :~ _ -> return [Some r] - r :? _ -> return [Some r] - _ -> return [] - where - a ++++ b = liftM2 (++) (safeIO a) (safeIO b) - -envMonadFunctionRefsIO :: (a -> EnvMonad b) -> IO [Some Ref] -envMonadFunctionRefsIO = safeIO . envMonadRefsIO . ($ error "catch me") - -safeIO :: IO [a] -> IO [a] -safeIO m = m `C.catch` \(C.SomeException _) -> return [] 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 @@ -17,44 +17,119 @@ ----------------------------------------------------------------------------- module Ideas.Common.Rule.Parameter - ( ParamTrans - , supplyParameters, supplyContextParameters + ( -- * Reading inputs + input, inputWith + , transInput1, transInput2, transInput3, transInputWith + , readRef2, readRef3 + -- * Writing outputs + , output, outputWith + , outputOnly, outputOnly2, outputOnly3, outputOnlyWith + , writeRef2, writeRef3, writeRef2_, writeRef3_ + -- * Named parameters + , ParamTrans , parameter1, parameter2, parameter3 + , transRef + , supplyParameters ) where import Control.Arrow +import Data.Maybe import Ideas.Common.Context import Ideas.Common.Environment -import Ideas.Common.Id -import Ideas.Common.Rule.EnvironmentMonad import Ideas.Common.Rule.Transformation import Ideas.Common.View ------------------------------------------------------------ ---- Bindables +---------------------------------------------------------------------------- +-- Reading inputs -type ParamTrans a b = Trans (a, b) b +input :: Ref i -> Trans (i, a) b -> Trans a b +input = inputWith . readRef -supplyParameters :: ParamTrans b a -> (a -> Maybe b) -> Transformation a -supplyParameters f g = transMaybe g &&& identity >>> f +inputWith :: Trans a i -> Trans (i, a) b -> Trans a b +inputWith f g = (f &&& identity) >>> g -supplyContextParameters :: ParamTrans b a -> (a -> EnvMonad b) -> Transformation (Context a) -supplyContextParameters f g = transLiftContextIn $ - transUseEnvironment (transEnvMonad g &&& identity) >>> first f +transInput1 :: Ref i -> (i -> a -> Maybe b) -> Trans a b +transInput1 = transInputWith . readRef -parameter1 :: (IsId n1, Reference a) => n1 -> (a -> Transformation b) -> ParamTrans a b -parameter1 n1 f = first (bindValue n1 >>> arr f) >>> app +transInput2 :: Ref i1 -> Ref i2 -> (i1 -> i2 -> a -> Maybe b) -> Trans a b +transInput2 r1 r2 = transInputWith (readRef2 r1 r2) . uncurry -parameter2 :: (IsId n1, IsId n2, Reference a, Reference b) - => n1 -> n2 -> (a -> b -> Transformation c) -> ParamTrans (a, b) c -parameter2 n1 n2 f = first (bindValue n1 *** bindValue n2 >>> arr (uncurry f)) >>> app +transInput3 :: Ref i1 -> Ref i2 -> Ref i3 -> (i1 -> i2 -> i3 -> a -> Maybe b) -> Trans a b +transInput3 r1 r2 r3 = transInputWith (readRef3 r1 r2 r3) . uncurry3 -parameter3 :: (IsId n1, IsId n2, IsId n3, Reference a, Reference b, Reference c) - => n1 -> n2 -> n3 -> (a -> b -> c -> Transformation d) -> ParamTrans (a, b, c) d -parameter3 n1 n2 n3 f = first ((\(a, b, c) -> (a, (b, c))) ^>> - bindValue n1 *** (bindValue n2 *** bindValue n3) >>^ - (\(a, (b, c)) -> f a b c)) - >>> app +transInputWith :: MakeTrans f => Trans a i -> (i -> a -> f b) -> Trans a b +transInputWith t = inputWith t . makeTrans . uncurry -bindValue :: (IsId n, Reference a) => n -> Trans a a -bindValue = transRef . makeRef +readRef2 :: Ref a -> Ref b -> Trans x (a, b) +readRef2 r1 r2 = readRef r1 &&& readRef r2 + +readRef3 :: Ref a -> Ref b -> Ref c -> Trans x (a, b, c) +readRef3 r1 r2 r3 = readRef r1 &&& readRef2 r2 r3 >>^ to3 + +---------------------------------------------------------------------------- +-- Writing outputs + +output :: Ref o -> Trans a (b, o) -> Trans a b +output = outputWith . writeRef + +outputWith :: Trans o x -> Trans a (b, o) -> Trans a b +outputWith f g = g >>> second f >>^ fst + +outputOnly :: Ref o -> Trans a o -> Trans a a +outputOnly = outputOnlyWith . writeRef + +outputOnly2 :: Ref o1 -> Ref o2 -> Trans a (o1, o2) -> Trans a a +outputOnly2 r1 = outputOnlyWith . writeRef2 r1 + +outputOnly3 :: Ref o1 -> Ref o2 -> Ref o3 -> Trans a (o1, o2, o3) -> Trans a a +outputOnly3 r1 r2 = outputOnlyWith . writeRef3 r1 r2 + +outputOnlyWith :: Trans o x -> Trans a o -> Trans a a +outputOnlyWith f g = ((g >>> f) &&& identity) >>^ snd + +writeRef2 :: Ref a -> Ref b -> Trans (a, b) (a, b) +writeRef2 r1 r2 = writeRef r1 *** writeRef r2 + +writeRef2_ :: Ref a -> Ref b -> Trans (a, b) () +writeRef2_ r1 r2 = writeRef2 r1 r2 >>^ const () + +writeRef3 :: Ref a -> Ref b -> Ref c -> Trans (a, b, c) (a, b, c) +writeRef3 r1 r2 r3 = from3 ^>> writeRef r1 *** writeRef2 r2 r3 >>^ to3 + +writeRef3_ :: Ref a -> Ref b -> Ref c -> Trans (a, b, c) () +writeRef3_ r1 r2 r3 = writeRef3 r1 r2 r3 >>^ const () + +---------------------------------------------------------------------------- +-- Named parameters + +type ParamTrans i a = Trans (i, a) a + +parameter1 :: Ref a -> (a -> b -> Maybe b) -> ParamTrans a b +parameter1 r1 f = first (transRef r1) >>> makeTrans (uncurry f) + +parameter2 :: Ref a -> Ref b -> (a -> b -> c -> Maybe c) -> ParamTrans (a, b) c +parameter2 r1 r2 f = first (transRef r1 *** transRef r2) >>> makeTrans (uncurry (uncurry f)) + +parameter3 :: Ref a -> Ref b -> Ref c -> (a -> b -> c -> d -> Maybe d) -> ParamTrans (a, b, c) d +parameter3 r1 r2 r3 f = first (from3 ^>> t >>^ to3) >>> makeTrans (uncurry (\(a, b, c) -> f a b c)) + where + t = transRef r1 *** (transRef r2 *** transRef r3) + +transRef :: Ref a -> Trans a a +transRef r = (identity &&& readRefMaybe r) >>> uncurry fromMaybe ^>> writeRef r + +supplyParameters :: ParamTrans b a -> Trans a b -> Transformation (Context a) +supplyParameters f g = transLiftContextIn $ + transUseEnvironment (g &&& identity) >>> first f + +----------------------------------------------------------------- +-- helpers + +from3 :: (a, b, c) -> (a, (b, c)) +from3 (a, b, c) = (a, (b, c)) + +to3 :: (a, (b, c)) -> (a, b, c) +to3 (a, (b, c)) = (a, b, c) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c 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 @@ -14,13 +14,11 @@ ( -- * data type and type class Recognizable(..), Recognizer -- * Constructor functions - , makeRecognizer, makeRecognizerEnvMonad, makeRecognizerTrans + , makeRecognizer, makeRecognizerTrans ) where -import Control.Monad import Data.Maybe import Ideas.Common.Environment -import Ideas.Common.Rule.EnvironmentMonad import Ideas.Common.Rule.Transformation import Ideas.Common.View @@ -58,10 +56,8 @@ --- Constructor functions makeRecognizer :: (a -> a -> Bool) -> Recognizer a -makeRecognizer eq = makeRecognizerEnvMonad $ \a b -> guard (eq a b) - -makeRecognizerEnvMonad :: (a -> a -> EnvMonad ()) -> Recognizer a -makeRecognizerEnvMonad = makeRecognizerTrans . makeTrans . uncurry +makeRecognizer eq = makeRecognizerTrans $ transMaybe $ \(x, y) -> + if eq x y then Just () else Nothing makeRecognizerTrans :: Trans (a, a) () -> Recognizer a makeRecognizerTrans = R 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 @@ -19,46 +19,48 @@ Transformation, Trans -- * Constructor functions , MakeTrans(..) - , transPure, transMaybe, transList, transEnvMonad - , transRewrite, transRef + , transPure, transMaybe, transList, transGuard, transRewrite + -- * Reading and writing (with references) + , readRef, readRefDefault, readRefMaybe + , writeRef, writeRef_, writeRefMaybe -- * Lifting transformations , transUseEnvironment , transLiftView, transLiftViewIn , transLiftContext, transLiftContextIn - , makeTransLiftContext, makeTransLiftContext_ -- * Using transformations , transApply, transApplyWith - , getRewriteRules, isZeroTrans + , getRewriteRules ) where +import Control.Applicative import Control.Arrow import Data.Maybe -import Data.Typeable import Ideas.Common.Classes import Ideas.Common.Context import Ideas.Common.Environment import Ideas.Common.Rewriting -import Ideas.Common.Rule.EnvironmentMonad -import Ideas.Common.Utils import Ideas.Common.View +import Ideas.Utils.Prelude import qualified Control.Category as C ----------------------------------------------------------- --- Trans data type and instances +type Transformation a = Trans a a + data Trans a b where Zero :: Trans a b List :: (a -> [b]) -> Trans a b Rewrite :: RewriteRule a -> Trans a a - EnvMonad :: (a -> EnvMonad b) -> Trans a b - Ref :: Typeable a => Ref a -> Trans a a UseEnv :: Trans a b -> Trans (a, Environment) (b, Environment) (:>>:) :: Trans a b -> Trans b c -> Trans a c (:**:) :: Trans a c -> Trans b d -> Trans (a, b) (c, d) (:++:) :: Trans a c -> Trans b d -> Trans (Either a b) (Either c d) - Apply :: Trans (Trans a b, a) b Append :: Trans a b -> Trans a b -> Trans a b + ReadRefM :: Ref a -> Trans x (Maybe a) + WriteRefM :: Ref a -> Trans (Maybe a) () + instance C.Category Trans where id = arr id (.) = flip (:>>:) @@ -80,15 +82,21 @@ left f = f :++: identity right f = identity :++: f -instance ArrowApply Trans where - app = Apply - instance Monoid (Trans a b) where mempty = zeroArrow mappend = (<+>) -type Transformation a = Trans a a +instance Functor (Trans a) where + fmap f t = t >>^ f +instance Applicative (Trans a) where + pure = transPure . const + s <*> t = (s &&& t) >>^ uncurry ($) + +instance Alternative (Trans a) where + empty = zeroArrow + (<|>) = (<+>) + ----------------------------------------------------------- --- Constructor functions @@ -103,9 +111,6 @@ instance MakeTrans [] where makeTrans = transList -instance MakeTrans EnvMonad where - makeTrans = transEnvMonad - transPure :: (a -> b) -> Trans a b transPure f = transList (return . f) @@ -115,17 +120,35 @@ transList :: (a -> [b]) -> Trans a b transList = List -transEnvMonad :: (a -> EnvMonad b) -> Trans a b -transEnvMonad = EnvMonad +transGuard :: (a -> Bool) -> Trans a a +transGuard p = transMaybe $ \x -> if p x then Just x else Nothing transRewrite :: RewriteRule a -> Trans a a transRewrite = Rewrite -transRef :: Typeable a => Ref a -> Trans a a -transRef = Ref +----------------------------------------------------------- +-- Reading and writing (with references) +readRef :: Ref a -> Trans x a +readRef r = readRefMaybe r >>> transMaybe id + +readRefDefault :: a -> Ref a -> Trans x a +readRefDefault a r = readRefMaybe r >>^ fromMaybe a + +readRefMaybe :: Ref a -> Trans x (Maybe a) +readRefMaybe = ReadRefM + +writeRef :: Ref a -> Trans a a +writeRef r = (identity &&& writeRef_ r) >>^ fst + +writeRef_ :: Ref a -> Trans a () +writeRef_ r = Just ^>> writeRefMaybe r + +writeRefMaybe :: Ref a -> Trans (Maybe a) () +writeRefMaybe = WriteRefM + ----------------------------------------------------------- ---- Lifting transformations +-- Lifting transformations transUseEnvironment :: Trans a b -> Trans (a, Environment) (b, Environment) transUseEnvironment = UseEnv @@ -134,7 +157,7 @@ transLiftView v = transLiftViewIn (v &&& identity) transLiftViewIn :: View a (b, c) -> Transformation b -> Transformation a -transLiftViewIn v f = makeTrans (match v) >>> first f >>> arr (build v) +transLiftViewIn v f = makeTrans (match v) >>> first f >>^ build v transLiftContext :: Transformation a -> Transformation (Context a) transLiftContext = transLiftContextIn . transUseEnvironment @@ -145,14 +168,6 @@ f (a, c) = ((a, environment c), c) g ((a, env), c) = (a, setEnvironment env c) --- | Overloaded variant of @transLiftContext@ -makeTransLiftContext :: MakeTrans f => (a -> f a) -> Transformation (Context a) -makeTransLiftContext = transLiftContext . makeTrans - --- | Overloaded variant of @transLiftContext@; ignores result -makeTransLiftContext_ :: MakeTrans f => (a -> f ()) -> Transformation (Context a) -makeTransLiftContext_ f = transLiftContext (identity &&& makeTrans f >>> arr fst) - ----------------------------------------------------------- --- Using transformations @@ -165,21 +180,18 @@ Zero -> [] List f -> [ (b, env) | b <- f a ] Rewrite r -> [ (b, env) | b <- applyAll r a ] - EnvMonad f -> runEnvMonad (f a) env - Ref ref -> case ref ? env of - Just b -> [(b, env)] - Nothing -> [(a, insertRef ref a env)] UseEnv f -> do (b, envb) <- transApplyWith (snd a) f (fst a) return ((b, envb), env) f :>>: g -> do (b, env1) <- transApplyWith env f a (c, env2) <- transApplyWith env1 g b return (c, env2) f :**: g -> do (b, env1) <- transApplyWith env f (fst a) - (c, env2) <- transApplyWith env g (snd a) - return ((b, c), env2 `mappend` env1) + (c, env2) <- transApplyWith env1 g (snd a) + return ((b, c), env2) f :++: g -> either (make Left f) (make Right g) a - Apply -> uncurry (transApplyWith env) a Append f g -> transApplyWith env f a ++ transApplyWith env g a + ReadRefM r -> [(r ? env, env)] + WriteRefM r -> [((), maybe (deleteRef r) (insertRef r) a env)] where make :: (b -> c) -> Trans a b -> a -> [(c, Environment)] make f g = map (mapFirst f) . transApplyWith env g @@ -193,27 +205,17 @@ instance HasRefs (Trans a b) where allRefs trans = case trans of - Ref r -> [Some r] - EnvMonad f -> envMonadFunctionRefs f - _ -> descendTrans allRefs trans - -isZeroTrans :: Trans a b -> Bool -isZeroTrans = or . rec - where - rec :: Trans a b -> [Bool] - rec trans = - case trans of - Zero -> [True] - Append f g -> [isZeroTrans f && isZeroTrans g] - _ -> descendTrans rec trans + ReadRefM r -> [Some r] + WriteRefM r -> [Some r] + _ -> descendTrans allRefs trans -- General recursion function (existentially quantified) descendTrans :: Monoid m => (forall x y . Trans x y -> m) -> Trans a b -> m descendTrans make trans = case trans of - UseEnv f -> make f - f :>>: g -> make f `mappend` make g - f :**: g -> make f `mappend` make g - f :++: g -> make f `mappend` make g - Append f g -> make f `mappend` make g - _ -> mempty + UseEnv f -> make f + f :>>: g -> make f `mappend` make g + f :**: g -> make f `mappend` make g + f :++: g -> make f `mappend` make g + Append f g -> make f `mappend` make g + _ -> mempty 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 @@ -31,7 +31,7 @@ , many, many1, replicate, option -- ** Negation and greedy combinators , check, not, repeat, repeat1, try, (|>), (./.) - , exhaustive, while, until + , exhaustive, while, until, dynamic -- ** Graph , DependencyGraph, dependencyGraph -- ** Traversal combinators 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 @@ -33,22 +33,22 @@ ) where import Data.Foldable (toList) +import Data.Maybe import Ideas.Common.Classes -import Ideas.Common.CyclicTree hiding (label) import Ideas.Common.Derivation import Ideas.Common.Environment import Ideas.Common.Id import Ideas.Common.Rewriting (RewriteRule) import Ideas.Common.Rule import Ideas.Common.Strategy.Choice +import Ideas.Common.Strategy.CyclicTree hiding (label) import Ideas.Common.Strategy.Prefix import Ideas.Common.Strategy.Process import Ideas.Common.Strategy.Sequence (Sequence(..), ready) import Ideas.Common.Strategy.StrategyTree -import Ideas.Common.Strategy.Symbol import Ideas.Common.View import Prelude hiding (sequence) -import qualified Ideas.Common.CyclicTree as Tree +import qualified Ideas.Common.Strategy.CyclicTree as Tree ----------------------------------------------------------- --- Strategy data-type @@ -99,11 +99,14 @@ toStrategy (LS info (S t)) = S (Tree.label info t) instance IsStrategy Rule where - toStrategy = S . leaf + toStrategy = S . leaf . LeafRule instance IsStrategy RewriteRule where toStrategy = toStrategy . ruleRewrite +instance IsStrategy Dynamic where + toStrategy = S . leaf . LeafDyn + liftS :: IsStrategy f => (Strategy a -> Strategy a) -> f a -> Strategy a liftS f = f . toStrategy @@ -184,20 +187,23 @@ -- | Returns a list of all major rules that are part of a labeled strategy rulesInStrategy :: IsStrategy f => f a -> [Rule a] -rulesInStrategy s = [ r | r <- toList (toStrategyTree s), isMajor r ] +rulesInStrategy s = concatMap f (toList (toStrategyTree s)) + where + f (LeafRule r) | isMajor r = [r] + f _ = [] instance LiftView LabeledStrategy where - liftViewIn = mapRules . liftViewIn + liftViewIn v (LS n s) = LS n (liftViewIn v s) instance LiftView Strategy where - liftViewIn = mapRulesS . liftViewIn + liftViewIn v = S . fmap (liftViewIn v) . toStrategyTree -- | Apply a function to all the rules that make up a labeled strategy -mapRules :: (Rule a -> Rule b) -> LabeledStrategy a -> LabeledStrategy b +mapRules :: (Rule a -> Rule a) -> LabeledStrategy a -> LabeledStrategy a mapRules f (LS n s) = LS n (mapRulesS f s) -mapRulesS :: (Rule a -> Rule b) -> Strategy a -> Strategy b -mapRulesS f = S . fmap f . unS +mapRulesS :: (Rule a -> Rule a) -> Strategy a -> Strategy a +mapRulesS = onStrategyTree . mapRulesInTree -- | Use a function as do-after hook for all rules in a labeled strategy, but -- also use the function beforehand @@ -219,12 +225,8 @@ onStrategyTree :: IsStrategy f => (StrategyTree a -> StrategyTree a) -> f a -> Strategy a onStrategyTree f = S . f . toStrategyTree -getProcess :: IsStrategy f => f a -> Process (Rule a) -getProcess = foldUnwind emptyAlg - { fNode = fromNary . combinator - , fLeaf = single - , fLabel = \l p -> enterRule l ~> p .*. (exitRule l ~> done) - } . toStrategyTree +getProcess :: IsStrategy f => f a -> Process (Leaf a) +getProcess = treeToProcess . toStrategyTree ------------------------- 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 @@ -18,13 +18,14 @@ import Data.Graph import Data.List ((\\)) import Data.Maybe -import Ideas.Common.CyclicTree hiding (label) import Ideas.Common.Id +import Ideas.Common.Rewriting (IsTerm) import Ideas.Common.Rule import Ideas.Common.Strategy.Abstract +import Ideas.Common.Strategy.CyclicTree hiding (label) import Ideas.Common.Strategy.Process import Ideas.Common.Strategy.StrategyTree -import Ideas.Common.Utils (fst3, thd3) +import Ideas.Utils.Prelude (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 @@ -132,7 +133,7 @@ -- strategy only succeeds if this is not the case (otherwise it fails). not :: IsStrategy f => f a -> Strategy a not = decl1 $ "not" .=. Unary (\x -> - Sequence.single $ checkRule "core.not" $ null . runProcess x) + Sequence.single $ LeafRule $ checkRule "core.not" $ null . runProcess x) -- | Repeat a strategy zero or more times (greedy version of 'many') repeat :: IsStrategy f => f a -> Strategy a @@ -168,6 +169,10 @@ -- | Apply the strategies from the list exhaustively (until this is no longer possible) exhaustive :: IsStrategy f => [f a] -> Strategy a exhaustive = declN $ "exhaustive" .=. Nary Derived.exhaustive + +-- | The structure of a dynamic strategy depends on the current term +dynamic :: (IsId n, IsStrategy f, IsTerm a) => n -> (a -> f a) -> Strategy a +dynamic n f = toStrategy $ makeDynamic n (toStrategyTree . f) -- Graph to strategy ---------------------- 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 @@ -23,17 +23,17 @@ import Data.Char import Ideas.Common.Classes -import Ideas.Common.CyclicTree hiding (label) import Ideas.Common.Id import Ideas.Common.Rule import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Choice +import Ideas.Common.Strategy.CyclicTree hiding (label) import Ideas.Common.Strategy.Derived (repeat1) import Ideas.Common.Strategy.Process hiding (fold) import Ideas.Common.Strategy.Sequence import Ideas.Common.Strategy.StrategyTree import Ideas.Common.Strategy.Symbol -import qualified Ideas.Common.CyclicTree as Tree +import qualified Ideas.Common.Strategy.CyclicTree as Tree --------------------------------------------------------------------- -- Types and constructors @@ -48,7 +48,7 @@ mconcat xs = Cfg [ y | Cfg ys <- xs, y <- ys ] mappend (Cfg xs) (Cfg ys) = Cfg (xs ++ ys) -data ConfigLocation = ByName Id +newtype ConfigLocation = ByName Id instance Show ConfigLocation where show (ByName a) = show a @@ -137,13 +137,13 @@ removeDecl = "removed" .=. Unary (const empty) collapseDecl :: Decl Unary -collapseDecl = "collapsed" .=. Unary (\a -> - case firsts a of - [(r, _)] -> maybe empty (`collapseWith` a) (isEnterRule r) - _ -> empty) +collapseDecl = "collapsed" .=. Unary f where + f a = case firsts a of + [(LeafRule r, _)] -> maybe empty (`collapseWith` a) (isEnterRule r) + _ -> empty collapseWith l = - single . makeRule l . runProcess + single . LeafRule . makeRule l . runProcess hideDecl :: Decl Unary hideDecl = "hidden" .=. Unary (fmap minor) diff --git a/src/Ideas/Common/Strategy/CyclicTree.hs b/src/Ideas/Common/Strategy/CyclicTree.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Common/Strategy/CyclicTree.hs @@ -0,0 +1,217 @@ +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Ideas.Common.Strategy.CyclicTree + ( -- * Data type + CyclicTree + -- * Constructor functions + , node, node0, node1, node2, leaf, label + -- * Querying + , isNode, isLeaf, isLabel + -- * Replace functions + , replaceNode, replaceLeaf, replaceLabel, shrinkTree + -- * Fold and algebra + , fold, foldUnwind + , CyclicTreeAlg, fNode, fLeaf, fLabel, fRec, fVar + , emptyAlg, monoidAlg + ) where + +import Control.Monad +import Data.List (intercalate) +import Ideas.Common.Classes +import Ideas.Common.Id +import Test.QuickCheck hiding (label) + +-------------------------------------------------------------- +-- Data type + +data CyclicTree a b + = Node a [CyclicTree a b] + | Leaf b + | Label Id (CyclicTree a b) + | Rec Int (CyclicTree a b) + | Var Int + +instance (Show a, Show b) => Show (CyclicTree a b) where + show = fold Alg + { fNode = \a xs -> show a ++ par xs + , fLeaf = show + , fLabel = \l s -> show l ++ ":" ++ s + , fRec = \n s -> '#' : show n ++ "=" ++ s + , fVar = \n -> '#' : show n + } + +instance BiFunctor CyclicTree where + biMap f g = fold idAlg {fNode = Node . f, fLeaf = Leaf . g} + +instance Functor (CyclicTree d) where + fmap = mapSecond + +instance Applicative (CyclicTree d) where + pure = leaf + p <*> q = fold idAlg {fLeaf = (<$> q)} p + +instance Monad (CyclicTree d) where + return = leaf + (>>=) = flip replaceLeaf + +instance Foldable (CyclicTree d) where + foldMap f = fold monoidAlg {fLeaf = f} + +instance Traversable (CyclicTree d) where + traverse f = fold emptyAlg + { fNode = \a -> fmap (node a) . sequenceA + , fLeaf = fmap leaf . f + , fLabel = fmap . label + , fRec = fmap . Rec + , fVar = pure . Var + } + +instance Fix (CyclicTree a b) where + fix f = Rec n (f (Var n)) + where + vs = vars (f (Var (-1))) + n = maximum (-1 : vs) + 1 + +instance (Arbitrary a, Arbitrary b) => Arbitrary (CyclicTree a b) where + arbitrary = sized arbTree + shrink = shrinkTree + +arbTree :: (Arbitrary a, Arbitrary b) => Int -> Gen (CyclicTree a b) +arbTree = rec 0 + where + rec vi 0 = frequency $ + (3, leaf <$> arbitrary) + : [ (1, elements (map Var [1..vi])) | vi > 0 ] + rec vi n = frequency + [ (3, node <$> arbitrary <*> ms) + , (2, rec vi 0) + , (1, label <$> genId <*> m) + , (1, Rec (vi+1) <$> rec (vi+1) (n `div` 2)) + ] + where + m = rec vi (n `div` 2) + genId = elements [ newId [c] | c <- ['A' .. 'Z']] + ms = choose (0, 3) >>= \i -> replicateM i m + +shrinkTree :: CyclicTree a b -> [CyclicTree a b] +shrinkTree tree = + case tree of + Node a ts -> ts ++ map (node a) (shrinkTrees ts) + Label l t -> t : map (Label l) (shrinkTree t) + Rec n t -> map (Rec n) (shrinkTree t) + _ -> [] + +-- shrink exactly one tree +shrinkTrees :: [CyclicTree a b] -> [[CyclicTree a b]] +shrinkTrees [] = [] +shrinkTrees (t:ts) = map (:ts) (shrinkTree t) ++ map (t:) (shrinkTrees ts) + +-- local helpers +par :: [String] -> String +par xs | null xs = "" + | otherwise = "(" ++ intercalate ", " xs ++ ")" + +vars :: CyclicTree a b -> [Int] +vars = fold monoidAlg {fVar = return} + +-------------------------------------------------------------- +-- Constructor functions + +node :: a -> [CyclicTree a b] -> CyclicTree a b +node = Node + +node0 :: a -> CyclicTree a b +node0 a = node a [] + +node1 :: a -> CyclicTree a b -> CyclicTree a b +node1 a x = node a [x] + +node2 :: a -> CyclicTree a b -> CyclicTree a b -> CyclicTree a b +node2 a x y = node a [x, y] + +leaf :: b -> CyclicTree a b +leaf = Leaf + +label :: IsId n => n -> CyclicTree a b -> CyclicTree a b +label = Label . newId + +-------------------------------------------------------------- +-- Querying + +isNode :: CyclicTree a b -> Maybe (a, [CyclicTree a b]) +isNode (Node a xs) = Just (a, xs) +isNode _ = Nothing + +isLeaf :: CyclicTree a b -> Maybe b +isLeaf (Leaf b) = Just b +isLeaf _ = Nothing + +isLabel :: CyclicTree a b -> Maybe (Id, CyclicTree a b) +isLabel (Label l t) = Just (l, t) +isLabel _ = Nothing + +-------------------------------------------------------------- +-- Replace functions + +replaceNode :: (a -> [CyclicTree a b] -> CyclicTree a b) -> CyclicTree a b -> CyclicTree a b +replaceNode f = fold idAlg {fNode = f} + +replaceLabel :: (Id -> CyclicTree a b -> CyclicTree a b) -> CyclicTree a b -> CyclicTree a b +replaceLabel f = fold idAlg {fLabel = f} + +replaceLeaf :: (b -> CyclicTree a c) -> CyclicTree a b -> CyclicTree a c +replaceLeaf f = fold idAlg {fLeaf = f} + +-------------------------------------------------------------- +-- Fold and algebra + +fold :: CyclicTreeAlg a b t -> CyclicTree a b -> t +fold alg = rec + where + rec (Node a ts) = fNode alg a (map rec ts) + rec (Leaf b) = fLeaf alg b + rec (Label l t) = fLabel alg l (rec t) + rec (Rec n t) = fRec alg n (rec t) + rec (Var n) = fVar alg n + +foldUnwind :: CyclicTreeAlg a b t -> CyclicTree a b -> t +foldUnwind alg = start . fold Alg + { fNode = \a fs sub -> fNode alg a (map ($ sub) fs) + , fLeaf = \b _ -> fLeaf alg b + , fLabel = \l f sub -> fLabel alg l (f sub) + , fRec = \n f sub -> let this = f (extend n this sub) + in this + , fVar = \n sub -> sub n + } + where + start f = f (error "foldUnwind: unbound var") + extend n a sub i + | i == n = a + | otherwise = sub i + +data CyclicTreeAlg a b t = Alg + { fNode :: a -> [t] -> t + , fLeaf :: b -> t + , fLabel :: Id -> t -> t + , fRec :: Int -> t -> t + , fVar :: Int -> t + } + +idAlg :: CyclicTreeAlg a b (CyclicTree a b) +idAlg = Alg Node Leaf Label Rec Var + +emptyAlg :: CyclicTreeAlg a b t +emptyAlg = let f = error "emptyAlg: uninitialized" in Alg f f f f f + +monoidAlg :: Monoid m => CyclicTreeAlg a b m +monoidAlg = Alg (const mconcat) mempty (const id) (const id) mempty 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 @@ -30,29 +30,19 @@ import Prelude hiding (sequence, replicate, repeat) import qualified Prelude -split :: (AtomicSymbol a, Choice b) - => (Process a -> Process a -> b) -> b -> Process a -> b -split op = split2 (op . single) op - --- Specialized version of split that also takes an operator for the special case --- that the left part of the split is a single symbol. -split2 :: (AtomicSymbol a, Choice b) - => (a -> Process a -> b) -> (Process a -> Process a -> b) -> b -> Process a -> b -split2 op1 op2 = withMenu f +split :: AtomicSymbol a => (a -> Bool) -> (Process a -> Process a) -> Process a -> Process a +split skipCond cont = rec (0 :: Int) where - f a | a == atomicOpen = rec (op2 . (a ~>)) 1 - | otherwise = op1 a - - rec acc n - | n == 0 = acc done - | otherwise = withMenu g empty + rec n = withMenu op empty where - g a = rec (acc . (a ~>)) (pm a n) - - pm :: AtomicSymbol a => a -> Int -> Int - pm a | a == atomicOpen = succ - | a == atomicClose = pred - | otherwise = id + op a = a ~> rest + where + next | a == atomicOpen = n+1 + | a == atomicClose = n-1 + | otherwise = n + rest | skipCond a = rec next + | next > 0 = rec next + | otherwise = cont -- atomic prefix (!*>) :: AtomicSymbol a => Process a -> Process a -> Process a @@ -81,21 +71,7 @@ where bothAreDone = withMenu stop2 . withMenu stop2 done stop2 _ _ = 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 - 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) + r %>> s = split isEnterSymbol (<%> s) r -- | Allows all permutations of the list permute :: (Choice a, Sequence a) => [a] -> a @@ -109,17 +85,13 @@ -- Alternate combinator (<@>) :: AtomicSymbol a => Process a -> Process a -> Process a -p0 <@> q0 = rec q0 p0 +p <@> q = bothOk p q .|. (p @>> q) where - rec q = let op b r = b .*. rec r q - in split op (bothOk q) - bothOk = withMenu (\_ _ -> empty) done + bothOk = withMenu (\_ _ -> empty) done + r @>> s = split (const False) (s <@>) r inits :: AtomicSymbol a => Process a -> Process a -inits = rec - where - rec p = done .|. split op empty p - op x = (x .*.) . rec +inits p = done .|. split (const False) inits p many :: (Sequence a, Fix a, Choice a) => a -> a many s = fix $ \x -> done .|. (s .*. x) 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 @@ -18,9 +18,9 @@ ) where import Data.Maybe -import Ideas.Common.CyclicTree import Ideas.Common.Id import Ideas.Common.Strategy.Abstract +import Ideas.Common.Strategy.CyclicTree ----------------------------------------------------------- --- Strategy locations 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 @@ -27,15 +27,18 @@ , Path, emptyPath, readPath, readPaths ) where -import Control.Monad +import Data.Char import Data.List (intercalate) +import Data.Maybe import Ideas.Common.Classes import Ideas.Common.Environment +import Ideas.Common.Rewriting.Term import Ideas.Common.Rule import Ideas.Common.Strategy.Choice import Ideas.Common.Strategy.Process import Ideas.Common.Strategy.Sequence -import Ideas.Common.Utils (splitsWithElem, readM) +import Ideas.Common.Strategy.StrategyTree +import Ideas.Utils.Prelude (splitsWithElem, readM) -------------------------------------------------------------------------------- -- Prefix datatype @@ -72,30 +75,41 @@ noPrefix = Prefix [] empty -- | Make a prefix from a core strategy and a start term. -makePrefix :: Process (Rule a) -> a -> Prefix a +makePrefix :: Process (Leaf a) -> a -> Prefix a makePrefix = snd . replayProcess emptyPath -- | Construct a prefix by replaying a path in a core strategy: the third -- argument is the current term. -replayProcess :: Path -> Process (Rule a) -> ([Rule a], a -> Prefix a) -replayProcess (Path is) = replay [] is +replayProcess :: Path -> Process (Leaf a) -> ([Rule a], a -> Prefix a) +replayProcess (Path is) = fromMaybe ([], const noPrefix) . replay [] is where - replay acc [] p = (reverse acc, createPrefix p) - replay acc (n:ns) p = - case getByIndex n (menu p) of - Just (a, r) -> replay (a:acc) ns r - _ -> ([], const noPrefix) + replay acc path p = + case path of + [] -> return (reverse acc, createPrefix p) + Input _:_ -> Nothing + Index n:ns -> do + (leaf, q) <- getByIndex n (menu p) + case (leaf, ns) of + (LeafRule r, _) -> replay (r:acc) ns q + (LeafDyn d, Input t:ns2) -> do + a <- dynamicFromTerm d t + replay acc ns2 (treeToProcess a .*. q) + _ -> Nothing createPrefix p = Prefix [Path is] . flip (rec []) p rec ns a = cut . onMenuWithIndex f doneMenu . menu where - f n r p = choice + f n (LeafDyn d) p = fromMaybe empty $ do + t <- dynamicToTerm d a + s <- dynamicFromTerm d t + return (rec (Input t:Index n:ns) a (treeToProcess s .*. p)) + f n (LeafRule r) p = choice [ r ?~> (b, env, mk b) | (b, env) <- transApply (transformation r) a ] where - ms = n:ns + ms = Index n:ns path = Path (is ++ reverse ms) mk b = Prefix [path] (rec ms b p) @@ -153,19 +167,33 @@ -- Path -- | A path encodes a location in a strategy. Paths are represented as a list --- of integers. -newtype Path = Path [Int] +-- of integers and terms (the latter act as input for the dynamic strategies). +newtype Path = Path [PathItem] deriving Eq +data PathItem = Index Int | Input Term + deriving Eq + +instance Show PathItem where + show (Index n) = show n + show (Input t) = show t + +instance Read PathItem where + readsPrec n s = + case dropWhile isSpace s of + s2@(c:_) | isDigit c -> map (mapFirst Index) (readsPrec n s2) + s2 -> map (mapFirst Input) (readsPrec n s2) + instance Show Path where show (Path is) = show is + showList = (++) . intercalate ";" . map show -- | The empty path. emptyPath :: Path emptyPath = Path [] readPath :: Monad m => String -> m Path -readPath = liftM Path . readM +readPath = fmap Path . readM readPaths :: Monad m => String -> m [Path] readPaths = mapM readPath . splitsWithElem ';' 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,4 +1,4 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes, ExistentialQuantification #-} ----------------------------------------------------------------------------- -- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -16,29 +16,90 @@ module Ideas.Common.Strategy.StrategyTree ( -- * StrategyTree type synonym - StrategyTree + StrategyTree, Leaf(..), treeToProcess, mapRulesInTree -- * Declarations (named combinators) , Decl, Combinator, associative, isAssociative, combinator , (.=.), applyDecl + -- * Dynamic strategies + , Dynamic, makeDynamic, dynamicToTerm, dynamicTree, dynamicFromTerm -- * Arities , Arity(..), Nullary(..), Unary(..), Binary(..), Nary(..) ) where +import Control.Monad import Data.Function import Data.Maybe -import Ideas.Common.CyclicTree +import Ideas.Common.Classes import Ideas.Common.Id +import Ideas.Common.Rewriting.Term (Term, IsTerm(..)) import Ideas.Common.Rule import Ideas.Common.Strategy.Choice +import Ideas.Common.Strategy.CyclicTree import Ideas.Common.Strategy.Process +import Ideas.Common.Strategy.Sequence +import Ideas.Common.Strategy.Symbol import Ideas.Common.View infix 1 .=. ------------------------------------------------------------------------------ -type StrategyTree a = CyclicTree (Decl Nary) (Rule a) +type StrategyTree a = CyclicTree (Decl Nary) (Leaf a) +data Leaf a = LeafRule (Rule a) + | LeafDyn (Dynamic a) + +instance Show (Leaf a) where + show = showId + +instance Eq (Leaf a) where + x == y = getId x == getId y + +instance HasId (Leaf a) where + getId (LeafRule r) = getId r + getId (LeafDyn d) = getId d + changeId f (LeafRule r) = LeafRule (changeId f r) + changeId f (LeafDyn d) = LeafDyn (changeId f d) + +instance AtomicSymbol (Leaf a) where + atomicOpen = LeafRule atomicOpen + atomicClose = LeafRule atomicClose + +instance LabelSymbol (Leaf a) where + isEnterSymbol (LeafRule r) = isEnterSymbol r + isEnterSymbol (LeafDyn _) = False + +instance Minor (Leaf a) where + isMinor (LeafRule r) = isMinor r + isMinor (LeafDyn _) = False + setMinor b (LeafRule r) = LeafRule (setMinor b r) + setMinor _ lf@(LeafDyn _) = lf + +instance Apply Leaf where + applyAll (LeafRule r) a = applyAll r a + applyAll (LeafDyn d) a = applyAll d a + +instance LiftView Leaf where + liftViewIn v (LeafRule r) = LeafRule (liftViewIn v r) + liftViewIn v (LeafDyn d) = LeafDyn (liftViewIn v d) + +treeToProcess :: StrategyTree a -> Process (Leaf a) +treeToProcess = foldUnwind emptyAlg + { fNode = fromNary . combinator + , fLeaf = single + , fLabel = \l p -> LeafRule (enterRule l) ~> p .*. (LeafRule (exitRule l) ~> done) + } + +mapRulesInTree :: (Rule a -> Rule a) -> StrategyTree a -> StrategyTree a +mapRulesInTree f = inTree + where + inTree = fmap inLeaf + + inLeaf (LeafRule r) = LeafRule (f r) + inLeaf (LeafDyn d) = LeafDyn (inDyn d) + + inDyn d = d { dynamicFromTerm = fmap inTree . dynamicFromTerm d } + applyDecl :: Arity f => Decl f -> f (StrategyTree a) applyDecl d = toArity (node (d {combinator = op}) . make) where @@ -54,8 +115,35 @@ ------------------------------------------------------------------------------ -type Combinator f = forall a . f (Process (Rule a)) +data Dynamic a = Dyn + { dynamicId :: Id + , dynamicToTerm :: a -> Maybe Term + , dynamicFromTerm :: Term -> Maybe (StrategyTree a) + } +instance HasId (Dynamic a) where + getId = dynamicId + changeId f d = d { dynamicId = changeId f (dynamicId d) } + +instance Apply Dynamic where + applyAll d a = maybe [] ((`runProcess` a) . treeToProcess) (dynamicTree d a) + +instance LiftView Dynamic where + liftViewIn v d = d + { dynamicToTerm = fmap fst . match v >=> dynamicToTerm d + , dynamicFromTerm = fmap (fmap (liftViewIn v)) . dynamicFromTerm d + } + +makeDynamic :: (IsId n, IsTerm a) => n -> (a -> StrategyTree a) -> Dynamic a +makeDynamic n f = Dyn (newId n) (Just . toTerm) (fmap f . fromTerm) + +dynamicTree :: Dynamic a -> a -> Maybe (StrategyTree a) +dynamicTree d = dynamicToTerm d >=> dynamicFromTerm d + +------------------------------------------------------------------------------ + +type Combinator f = forall a . f (Process (Leaf a)) + data Decl f = C { declId :: Id , combinator :: Combinator f @@ -85,10 +173,10 @@ toArity :: ([a] -> a) -> f a liftIso :: Isomorphism a b -> f a -> f b -data Nullary a = Nullary { fromNullary :: a } -data Unary a = Unary { fromUnary :: a -> a } -data Binary a = Binary { fromBinary :: a -> a -> a } -data Nary a = Nary { fromNary :: [a] -> a } +newtype Nullary a = Nullary { fromNullary :: a } +newtype Unary a = Unary { fromUnary :: a -> a } +newtype Binary a = Binary { fromBinary :: a -> a -> a } +newtype Nary a = Nary { fromNary :: [a] -> a } instance Arity Nullary where listify (Nullary a) [] = Just a 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 @@ -37,7 +37,7 @@ import Data.Maybe import Ideas.Common.Traversal.Iterator import Ideas.Common.Traversal.Utils -import Ideas.Common.Utils.Uniplate +import Ideas.Utils.Uniplate import Test.QuickCheck --------------------------------------------------------------- @@ -69,7 +69,7 @@ childnr :: a -> Int location :: a -> Location -- default definitions - downLast = liftM (fixp right) . down + downLast = fmap (fixp right) . down childnr = pred . length . fixpl left location = toLocation . map childnr . drop 1 . reverse . fixpl up @@ -173,7 +173,7 @@ update a = (unwrap a, wrap) instance Navigator a => Iterator (PreOrder a) where - previous = liftWrapper ((liftM rightMostLeaf . left) >|< up) + previous = liftWrapper ((fmap rightMostLeaf . left) >|< up) next = let rec = right >|< (up >=> rec) in liftWrapper (down >|< rec) first = mapWrapper top @@ -249,10 +249,10 @@ instance Navigator a => Iterator (Leafs a) where previous = liftWrapper $ let rec = left >|< (up >=> rec) - in liftM rightMostLeaf . rec + in fmap rightMostLeaf . rec next = liftWrapper $ let rec = right >|< (up >=> rec) - in liftM leftMostLeaf . rec + in fmap leftMostLeaf . rec first = mapWrapper (leftMostLeaf . top) final = mapWrapper (rightMostLeaf . top) @@ -300,8 +300,8 @@ } instance Iterator (StrIterator a) where - next (SI n a) = liftM (SI (n+1)) $ searchNext ok a - previous (SI n a) = liftM (SI (n-1)) $ searchPrevious ok a + next (SI n a) = SI (n+1) <$> searchNext ok a + previous (SI n a) = SI (n-1) <$> searchPrevious ok a first (SI _ a) = SI 0 $ safe (searchForward ok) (first a) final (SI _ a) = finalSI $ safe (searchBackward ok) (final a) position = posSI @@ -350,8 +350,8 @@ down = downWith focusM downLast = downWith lastStrIterator - left (U fs a) = liftM (U fs) (previous a) - right (U fs a) = liftM (U fs) (next a) + left (U fs a) = U fs <$> previous a + right (U fs a) = U fs <$> next a childnr (U _ a) = position a @@ -364,7 +364,7 @@ unfocus = current . top instance (Arbitrary a, Uniplate a) => Arbitrary (UniplateNavigator a) where - arbitrary = liftM focus arbitrary >>= genNav + arbitrary = fmap focus arbitrary >>= genNav where genNav a = case map genNav (downs a) of @@ -373,7 +373,7 @@ downWith :: Uniplate a => (Str a -> Maybe (StrIterator a)) -> UniplateNavigator a -> Maybe (UniplateNavigator a) -downWith make (U fs a) = liftM (U (f:fs)) (make cs) +downWith make (U fs a) = U (f:fs) <$> make cs where (cs, g) = uniplate (current a) f = (`replace` a) . g . unfocus 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 @@ -20,8 +20,8 @@ import Ideas.Common.Traversal.Iterator import Ideas.Common.Traversal.Navigator import Ideas.Common.Traversal.Utils -import Ideas.Common.Utils.TestSuite -import Ideas.Common.Utils.Uniplate +import Ideas.Utils.TestSuite +import Ideas.Utils.Uniplate import Test.QuickCheck hiding ((===)) testIterator :: (Show a, Eq a, Iterator a) => String -> Gen a -> TestSuite @@ -72,8 +72,8 @@ ] , suite "down/downLast" - [ prop gen "down; rightMost" $ liftM rightMost . down === downLast - , prop gen "downLast; leftMost" $ liftM leftMost . downLast === down + [ prop gen "down; rightMost" $ fmap rightMost . down === downLast + , prop gen "downLast; leftMost" $ fmap leftMost . downLast === down , prop gen "down is leftMost" $ isNothing . (down >=> left) , prop gen "downLast is rightMost" $ isNothing . (downLast >=> right) ] @@ -104,16 +104,16 @@ tests = suite "Iterators" [ testIterator "List" listGen - , testIterator "Mirror" $ liftM makeMirror listGen - , testIterator "Leafs" $ liftM makeLeafs uniGen - , testIterator "PreOrder" $ liftM makePreOrder uniGen - , testIterator "PostOrder" $ liftM makePostOrder uniGen - , testIterator "Horizontal" $ liftM makeHorizontal uniGen - , testIterator "LevelOrder" $ liftM makeLevelOrder uniGen + , testIterator "Mirror" $ makeMirror <$> listGen + , testIterator "Leafs" $ makeLeafs <$> uniGen + , testIterator "PreOrder" $ makePreOrder <$> uniGen + , testIterator "PostOrder" $ makePostOrder <$> uniGen + , testIterator "Horizontal" $ makeHorizontal <$> uniGen + , testIterator "LevelOrder" $ makeLevelOrder <$> uniGen ] <> suite "Navigators" [ testNavigator "Uniplate" uniGen - , testNavigator "Mirror" $ liftM makeMirror uniGen + , testNavigator "Mirror" $ makeMirror <$> uniGen ] _go :: IO () 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 @@ -46,7 +46,7 @@ changeM = changeG changeG :: (Update f, Monad g) => (a -> g a) -> f a -> g (f a) -changeG f a = liftM (`replace` a) (f (current a)) +changeG f a = (`replace` a) <$> f (current a) --------------------------------------------------------------- -- Focus type class @@ -61,10 +61,10 @@ focusM = Just . focus liftFocus :: Focus a => (Unfocus a -> Maybe (Unfocus a)) -> a -> Maybe a -liftFocus f = liftM focus . f . unfocus +liftFocus f = fmap focus . f . unfocus unliftFocus :: Focus a => (a -> Maybe a) -> Unfocus a -> Maybe (Unfocus a) -unliftFocus f = liftM unfocus . f . focus +unliftFocus f = fmap unfocus . f . focus --------------------------------------------------------------- -- Wrapper type class @@ -74,10 +74,10 @@ unwrap :: f a -> a liftWrapper :: (Monad m, Wrapper f) => (a -> m a) -> f a -> m (f a) -liftWrapper f = liftM wrap . f . unwrap +liftWrapper f = fmap wrap . f . unwrap unliftWrapper :: (Monad m, Wrapper f) => (f a -> m (f a)) -> a -> m a -unliftWrapper f = liftM unwrap . f . wrap +unliftWrapper f = fmap unwrap . f . wrap mapWrapper :: Wrapper f => (a -> a) -> f a -> f a mapWrapper f = wrap . f . unwrap diff --git a/src/Ideas/Common/Utils.hs b/src/Ideas/Common/Utils.hs deleted file mode 100644 --- a/src/Ideas/Common/Utils.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-} ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A collection of general utility functions --- ------------------------------------------------------------------------------ - -module Ideas.Common.Utils - ( Some(..), ShowString(..), readInt, readM - , subsets, isSubsetOf - , cartesian, distinct, allsame - , fixpoint - , splitAtElem, splitsWithElem - , timedSeconds - , fst3, snd3, thd3 - , headM, findIndexM - , elementAt, changeAt, replaceAt - , list - ) where - -import Data.Char -import Data.List -import Data.Typeable -import System.Timeout - -data Some f = forall a . Some (f a) - -data ShowString = ShowString { fromShowString :: String } - 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 - | any (not . isDigit) xs = Nothing - | otherwise = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' - -readM :: (Monad m, Read a) => String -> m a -readM s = case reads s of - [(a, xs)] | all isSpace xs -> return a - _ -> fail ("no read: " ++ s) - -subsets :: [a] -> [[a]] -subsets = foldr op [[]] - where op a xs = xs ++ map (a:) xs - -isSubsetOf :: Eq a => [a] -> [a] -> Bool -isSubsetOf xs ys = all (`elem` ys) xs - -cartesian :: [a] -> [b] -> [(a, b)] -cartesian as bs = [ (a, b) | a <- as, b <- bs ] - -distinct :: Eq a => [a] -> Bool -distinct [] = True -distinct (x:xs) = notElem x xs && distinct xs - -allsame :: Eq a => [a] -> Bool -allsame [] = True -allsame (x:xs) = all (==x) xs - -fixpoint :: Eq a => (a -> a) -> a -> a -fixpoint f = rec . iterate f - where - rec [] = error "Ideas.Common.Utils: empty list" - rec (x:xs) - | x == head xs = x - | otherwise = rec xs - -splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a]) -splitAtElem c s = - case break (==c) s of - (xs, _:ys) -> Just (xs, ys) - _ -> Nothing - -splitsWithElem :: Eq a => a -> [a] -> [[a]] -splitsWithElem c s = - case splitAtElem c s of - Just (xs, ys) -> xs : splitsWithElem c ys - Nothing -> [s] - -timedSeconds :: Int -> IO a -> IO a -timedSeconds n m = timeout (n * 10^(6 :: Int)) m >>= - maybe (fail ("Timeout after " ++ show n ++ " seconds")) return - -fst3 :: (a, b, c) -> a -fst3 (x, _, _) = x - -snd3 :: (a, b, c) -> b -snd3 (_, x, _) = x - -thd3 :: (a, b, c) -> c -thd3 (_, _, x) = x - --- generalized list functions (results in monad) -headM :: Monad m => [a] -> m a -headM (a:_) = return a -headM _ = fail "headM" - -findIndexM :: Monad m => (a -> Bool) -> [a] -> m Int -findIndexM p = maybe (fail "findIndexM") return . findIndex p - -elementAt :: Monad m => Int -> [a] -> m a -elementAt i = headM . drop i - -changeAt :: Monad m => Int -> (a -> a) -> [a] -> m [a] -changeAt i f as = - case splitAt i as of - (xs, y:ys) -> return (xs ++ f y : ys) - _ -> fail "changeAt" - -replaceAt :: Monad m => Int -> a -> [a] -> m [a] -replaceAt i = changeAt i . const - -list :: b -> ([a] -> b) -> [a] -> b -list b f xs = if null xs then b else f xs diff --git a/src/Ideas/Common/Utils/QuickCheck.hs b/src/Ideas/Common/Utils/QuickCheck.hs deleted file mode 100644 --- a/src/Ideas/Common/Utils/QuickCheck.hs +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Extensions to the QuickCheck library --- ------------------------------------------------------------------------------ - -module Ideas.Common.Utils.QuickCheck - ( module Test.QuickCheck - -- * Data type - , ArbGen, generator, generators - -- * Constructors - , arbGen, constGen, constGens, unaryGen, unaryGens - , unaryArbGen, binaryGen, binaryGens, toArbGen - -- * Frequency combinators - , common, uncommon, rare, changeFrequency - ) where - -import Control.Arrow -import Control.Monad -import Data.Ratio -import Test.QuickCheck - ---------------------------------------------------------- --- @ArbGen@ datatype - -newtype ArbGen a = AG [(Rational, (Int, Gen ([a] -> a)))] - -instance Monoid (ArbGen a) where - mempty = AG mempty - AG xs `mappend` AG ys = AG (xs `mappend` ys) - -generator :: ArbGen a -> Gen a -generator (AG pairs) = sized rec - where - factor = foldr (lcm . denominator . fst) 1 pairs - rec n = frequency (map make (select pairs)) - where - select - | n == 0 = filter ((==0) . fst . snd) - | otherwise = id - make (r, (a, gf)) = - let m = round (fromInteger factor*r) - xs = replicateM a $ rec $ n `div` 2 - in (m, liftM2 ($) gf xs) - -generators :: [ArbGen a] -> Gen a -generators = generator . mconcat - ---------------------------------------------------------- --- Constructors - -arbGen :: Arbitrary b => (b -> a) -> ArbGen a -arbGen f = newGen 0 (liftM (const . f) arbitrary) - -constGen :: a -> ArbGen a -constGen = pureGen 0 . const - -constGens :: [a] -> ArbGen a -constGens = mconcat . map constGen - -unaryGen :: (a -> a) -> ArbGen a -unaryGen f = pureGen 1 (f . head) - -unaryArbGen :: Arbitrary b => (b -> a -> a) -> ArbGen a -unaryArbGen f = newGen 1 $ liftM (\a -> f a . head) arbitrary - -unaryGens :: [a -> a] -> ArbGen a -unaryGens = mconcat . map unaryGen - -binaryGen :: (a -> a -> a) -> ArbGen a -binaryGen f = pureGen 2 (\xs -> f (head xs) (xs !! 1)) - -binaryGens :: [a -> a -> a] -> ArbGen a -binaryGens = mconcat . map binaryGen - -pureGen :: Int -> ([a] -> a) -> ArbGen a -pureGen n = newGen n . return - -toArbGen :: Gen a -> ArbGen a -toArbGen = newGen 0 . liftM const - -newGen :: Int -> Gen ([a] -> a) -> ArbGen a -newGen n f = AG [(1, (n, f))] - ---------------------------------------------------------- --- Frequency combinators - -common, uncommon, rare :: ArbGen a -> ArbGen a -common = changeFrequency 2 -uncommon = changeFrequency (1/2) -rare = changeFrequency (1/5) - -changeFrequency :: Rational -> ArbGen a -> ArbGen a -changeFrequency r (AG xs) = AG (map (first (*r)) xs) diff --git a/src/Ideas/Common/Utils/StringRef.hs b/src/Ideas/Common/Utils/StringRef.hs deleted file mode 100644 --- a/src/Ideas/Common/Utils/StringRef.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- References to Strings, proving a fast comparison implementation (Eq and --- Ord) that uses a hash function. Code is based on Daan Leijen's Lazy --- Virutal Machine (LVM) identifiers. --- ------------------------------------------------------------------------------ - -module Ideas.Common.Utils.StringRef - ( StringRef, stringRef, toString, tableStatus - ) where - -import Data.Bits -import Data.Data -import Data.IORef -import Data.List -import System.IO.Unsafe -import qualified Data.IntMap as IM - ----------------------------------------------------------------- --- StringRef datatype and instance declarations - -data StringRef = S !Int - deriving (Eq, Ord, Data, Typeable) - ----------------------------------------------------------------- --- Hash table - -type HashTable = IM.IntMap [String] - -{-# NOINLINE tableRef #-} -tableRef :: IORef HashTable -tableRef = unsafePerformIO (newIORef IM.empty) - ----------------------------------------------------------------- --- Conversion to and from strings - -stringRef :: String -> StringRef -stringRef s = unsafePerformIO $ do - let hash = hashString s - m <- readIORef tableRef - case IM.insertLookupWithKey (const combine) hash [s] m of - (Nothing, new) -> do - writeIORef tableRef new - return (S (encodeIndexZero hash)) - (Just old, new) -> - case elemIndex s old of - Just index -> - return (S (encode hash index)) - Nothing -> do - let index = length old - writeIORef tableRef new - return (S (encode hash index)) - -toString :: StringRef -> String -toString (S i) = unsafePerformIO $ do - m <- readIORef tableRef - case IM.lookup (extractHash i) m of - Just xs -> return (atIndex (extractIndex i) xs) - Nothing -> intErr "id not found" - ----------------------------------------------------------------- --- Bit encoding - -encode :: Int -> Int -> Int -encode hash index = hash + index `shiftL` 12 - -encodeIndexZero :: Int -> Int -encodeIndexZero hash = hash - -extractHash :: Int -> Int -extractHash i = i `mod` 4096 - -extractIndex :: Int -> Int -extractIndex i = i `shiftR` 12 - ----------------------------------------------------------------- --- Hash function - --- simple hash function that performs quite good in practice -hashString :: String -> Int -hashString s = (f s `mod` prime) `mod` maxHash - where - f = foldl' next 0 -- ' strict fold - next n c = n*65599 + fromEnum c - prime = 32537 --65599 -- require: prime < maxHash - -maxHash :: Int -maxHash = 0xFFF -- 12 bits - ----------------------------------------------------------------- --- Utility functions - -atIndex :: Int -> [a] -> a -atIndex 0 (x:_) = x -atIndex i (_:xs) = atIndex (i-1) xs -atIndex _ _ = intErr "corrupt symbol table" - -combine :: Eq a => [a] -> [a] -> [a] -combine [a] = rec - where - rec [] = [a] - rec this@(x:xs) - | a == x = this - | otherwise = x:rec xs -combine _ = intErr "combine" - -intErr :: String -> a -intErr s = error ("Internal error in Ideas.Common.StringRef: " ++ s) - ----------------------------------------------------------------- --- Testing and debugging - -tableStatus :: IO String -tableStatus = readIORef tableRef >>= \m -> - let xs = map f (IM.assocs m) - f (i, ys) = '#' : show i ++ ": " ++ intercalate ", " (map g (frequency ys)) ++ - " [total = " ++ show (length ys) ++ "]" - g (a, n) | n == 1 = show a - | otherwise = show a ++ " (" ++ show n ++ ")" - in return $ unlines xs - -frequency :: Eq a => [a] -> [(a, Int)] -frequency [] = [] -frequency (x:xs) = - let (ys, zs) = partition (==x) xs - in (x, 1+length ys) : frequency zs diff --git a/src/Ideas/Common/Utils/TestSuite.hs b/src/Ideas/Common/Utils/TestSuite.hs deleted file mode 100644 --- a/src/Ideas/Common/Utils/TestSuite.hs +++ /dev/null @@ -1,420 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- A lightweight wrapper for organizing tests (including QuickCheck tests). It --- introduces the notion of a test suite, and it stores the test results for --- later inspection (e.g., for the generation of a test report). A TestSuite --- is a monoid. --- ------------------------------------------------------------------------------ - -module Ideas.Common.Utils.TestSuite - ( -- * TestSuite - TestSuite, module Data.Monoid - , suite, useProperty, usePropertyWith - , assertTrue, assertNull, assertEquals, assertIO - , assertMessage, assertMessageIO - , onlyWarnings, rateOnError - -- * Running a test suite - , runTestSuite, runTestSuiteResult - -- * Test Suite Result - , Result, subResults, findSubResult - , justOneSuite, allMessages, topMessages - , nrOfTests, nrOfErrors, nrOfWarnings - , timeInterval, makeSummary, printSummary - -- * Message - , Message, message, warning, messageLines - -- * Status - , Status, HasStatus(..) - , isError, isWarning, isOk - -- * Rating - , Rating, HasRating(..) - ) where - -import Control.Exception -import Control.Monad -import Data.Foldable (toList) -import Data.IORef -import Data.List -import Data.Maybe -import Data.Monoid -import Data.Time -import System.IO -import Test.QuickCheck hiding (Result) -import qualified Data.Sequence as S - ----------------------------------------------------------------- --- Test Suite - -newtype TestSuite = TS (S.Seq Test) - -data Test = Case String (IO Message) - | Suite String TestSuite - -instance Monoid TestSuite where - mempty = TS mempty - TS xs `mappend` TS ys = TS (xs <> ys) - -tests :: TestSuite -> [Test] -tests (TS xs) = toList xs - -makeTestSuite :: Test -> TestSuite -makeTestSuite = TS . S.singleton - ----------------------------------------------------------------- --- Test suite constructors - --- | Construct a (named) test suite containing test cases and other suites -suite :: String -> [TestSuite] -> TestSuite -suite s = makeTestSuite . Suite s . mconcat - --- | Turn a QuickCheck property into the test suite. The first argument is --- a label for the property -useProperty :: Testable prop => String -> prop -> TestSuite -useProperty = flip usePropertyWith stdArgs - --- | Turn a QuickCheck property into the test suite, also providing a test --- configuration (Args) -usePropertyWith :: Testable prop => String -> Args -> prop -> TestSuite -usePropertyWith s args = - makeTestSuite . Case s . liftM make . quickCheckWithResult args {chatty=False} - where - make qc = - case qc of - Success {} -> - mempty - Failure {reason = msg} -> - message msg - NoExpectedFailure {} -> - 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 - -assertNull :: Show a => String -> [a] -> TestSuite -assertNull s xs = assertMessages s (null xs) (map show xs) - -assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite -assertEquals s x y = assertMessage s (x==y) $ - "not equal " ++ show x ++ " and " ++ show y - -assertMessage :: String -> Bool -> String -> TestSuite -assertMessage s b = assertMessages s b . return - -assertMessages :: String -> Bool -> [String] -> TestSuite -assertMessages s b xs = makeTestSuite . Case s $ return $ - if b then mempty else mconcat (map message xs) - -assertIO :: String -> IO Bool -> TestSuite -assertIO s = makeTestSuite . Case s . liftM f - where - f b = if b then mempty else message "assertion failed" - -assertMessageIO :: String -> IO Message -> TestSuite -assertMessageIO s = makeTestSuite . Case s - --- | All errors are turned into warnings -onlyWarnings :: TestSuite -> TestSuite -onlyWarnings = changeMessages $ \m -> - m { messageStatus = messageStatus m `min` Warning - , messageRating = mempty - } - -rateOnError :: Int -> TestSuite -> TestSuite -rateOnError n = changeMessages $ \m -> - if isError m then m { messageRating = Rating n } else m - -changeMessages :: (Message -> Message) -> TestSuite -> TestSuite -changeMessages f = changeTS - where - changeTS (TS xs) = TS (fmap changeTest xs) - changeTest (Case s io) = Case s (liftM f io) - changeTest (Suite s t) = Suite s (changeTS t) - ----------------------------------------------------------------- --- Running a test suite - -runTestSuite :: Bool -> TestSuite -> IO () -runTestSuite chattyIO = void . runTestSuiteResult chattyIO - -runTestSuiteResult :: Bool -> TestSuite -> IO Result -runTestSuiteResult chattyIO ts = do - hSetBuffering stdout NoBuffering - ref <- newIORef 0 - result <- runner ref chattyIO ts - newline ref - return result - -runner :: IORef Int -> Bool -> TestSuite -> IO Result -runner ref chattyIO = runTS - where - runTS :: TestSuite -> IO Result - runTS ts = do - (res, dt) <- getDiffTime (foldM addTest mempty (tests ts)) - returnStrict res { diffTime = dt } - - runTest :: Test -> IO Result - runTest t = - case t of - Suite s xs -> runSuite s xs - Case s io -> runTestCase s io - - runSuite ::String -> TestSuite -> IO Result - runSuite s ts = do - when chattyIO $ do - newline ref - putStrLn s - reset ref - result <- runTS ts - returnStrict (suiteResult s result) - - runTestCase :: String -> IO Message -> IO Result - runTestCase s io = do - msg <- io `catch` handler - case messageStatus msg of - _ | not chattyIO -> return () - Ok -> dot ref - _ -> do - newlineIndent ref - print msg - reset ref - returnStrict (caseResult (s, msg)) - where - handler :: SomeException -> IO Message - handler = return . message . show - - addTest :: Result -> Test -> IO Result - addTest res t = liftM (res <>) (runTest t) - --- formatting helpers -type WriteIO a = IORef Int -> IO a - -newline :: WriteIO () -newline ref = do - i <- readIORef ref - when (i>0) (putChar '\n') - reset ref - -newlineIndent :: WriteIO () -newlineIndent ref = do - newline ref - putStr " " - writeIORef ref 3 - -dot :: WriteIO () -dot ref = do - i <- readIORef ref - unless (i>0 && i<60) (newlineIndent ref) - putChar '.' - modifyIORef ref (+1) - -reset :: WriteIO () -reset = (`writeIORef` 0) - ----------------------------------------------------------------- --- Test Suite Result - -data Result = Result - { suites :: S.Seq (String, Result) - , cases :: S.Seq (String, Message) - , diffTime :: !NominalDiffTime - , nrOfTests :: !Int - , nrOfWarnings :: !Int - , nrOfErrors :: !Int - , resultRating :: !Rating - } - --- one-line summary -instance Show Result where - show result = - "(tests: " ++ show (nrOfTests result) ++ - ", errors: " ++ show (nrOfErrors result) ++ - ", warnings: " ++ show (nrOfWarnings result) ++ - ", " ++ show (diffTime result) ++ ")" - -instance Monoid Result where - mempty = Result mempty mempty 0 0 0 0 mempty - x `mappend` y = Result - { suites = suites x <> suites y - , cases = cases x <> cases y - , diffTime = diffTime x + diffTime y - , nrOfTests = nrOfTests x + nrOfTests y - , nrOfWarnings = nrOfWarnings x + nrOfWarnings y - , nrOfErrors = nrOfErrors x + nrOfErrors y - , resultRating = resultRating x <> resultRating y - } - -instance HasStatus Result where - getStatus r | nrOfErrors r > 0 = Error - | nrOfWarnings r > 0 = Warning - | otherwise = Ok - -instance HasRating Result where - rating = rating . resultRating - rate n a = a {resultRating = Rating n} - -suiteResult :: String -> Result -> Result -suiteResult s res = mempty - { suites = S.singleton (s, res) - , nrOfTests = nrOfTests res - , nrOfWarnings = nrOfWarnings res - , nrOfErrors = nrOfErrors res - , resultRating = resultRating res - } - -caseResult :: (String, Message) -> Result -caseResult x@(_, msg) = - case getStatus msg of - Ok -> new - Warning -> new { nrOfWarnings = 1 } - Error -> new { nrOfErrors = 1 } - where - new = mempty - { cases = S.singleton x - , nrOfTests = 1 - , resultRating = messageRating msg - } - -subResults :: Result -> [(String, Result)] -subResults = toList . suites - -topMessages :: Result -> [(String, Message)] -topMessages = toList . cases - -allMessages :: Result -> [(String, Message)] -allMessages res = - topMessages res ++ concatMap (allMessages . snd) (subResults res) - -findSubResult :: String -> Result -> Maybe Result -findSubResult name = listToMaybe . recs - where - recs = concatMap rec . subResults - rec (n, t) - | n == name = [t] - | otherwise = recs t - -justOneSuite :: Result -> Maybe (String, Result) -justOneSuite res = - case subResults res of - [x] | S.null (cases res) -> Just x - _ -> Nothing - -timeInterval :: Result -> Double -timeInterval = fromRational . toRational . diffTime - -printSummary :: Result -> IO () -printSummary = putStrLn . makeSummary - -makeSummary :: Result -> String -makeSummary result = unlines $ - [ line - , "Tests : " ++ show (nrOfTests result) - , "Errors : " ++ show (nrOfErrors result) - , "Warnings : " ++ show (nrOfWarnings result) - , "" - , "Time : " ++ show (diffTime result) - , "" - , "Suites: " - ] ++ map f (subResults result) - ++ [line] - where - line = replicate 75 '-' - f (name, r) = " " ++ name ++ " " ++ show r - ------------------------------------------------------ --- Message - -data Message = M - { messageStatus :: !Status - , messageRating :: !Rating - , messageLines :: [String] - } - deriving Eq - -instance Show Message where - show a = st ++ sep ++ msg - where - msg = intercalate ", " (messageLines a) - sep = if null st || null msg then "" else ": " - st | isError a = "error" - | isWarning a = "warning" - | null (messageLines a) = "ok" - | otherwise = "" - -instance Monoid Message where - mempty = M mempty mempty mempty - M s r xs `mappend` M t q ys = M (s <> t) (r <> q) (xs <> ys) - -instance HasStatus Message where - getStatus = messageStatus - -instance HasRating Message where - rating = rating . messageRating - rate n a = a {messageRating = Rating n} - -message :: String -> Message -message = M Error (Rating 0) . return - -warning :: String -> Message -warning = M Warning mempty . return - ------------------------------------------------------ --- Status - -data Status = Ok | Warning | Error - deriving (Eq, Ord) - -instance Monoid Status where - mempty = Ok - mappend = max - -class HasStatus a where - getStatus :: a -> Status - -isOk, isWarning, isError :: HasStatus a => a -> Bool -isOk = (== Ok) . getStatus -isWarning = (== Warning) . getStatus -isError = (== Error) . getStatus - ------------------------------------------------------ --- Rating - -data Rating = Rating !Int | MaxRating - deriving (Eq, Ord) - -instance Monoid Rating where - mempty = MaxRating - mappend = min - -class HasRating a where - rating :: a -> Maybe Int - rate :: Int -> a -> a - -instance HasRating Rating where - rating (Rating n) = Just n - rating MaxRating = Nothing - rate = const . Rating - ------------------------------------------------------ --- Utility function - -getDiffTime :: IO a -> IO (a, NominalDiffTime) -getDiffTime action = do - t0 <- getCurrentTime - a <- action - t1 <- getCurrentTime - return (a, diffUTCTime t1 t0) - -returnStrict :: Monad m => a -> m a -returnStrict a = a `seq` return a diff --git a/src/Ideas/Common/Utils/Uniplate.hs b/src/Ideas/Common/Utils/Uniplate.hs deleted file mode 100644 --- a/src/Ideas/Common/Utils/Uniplate.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Exports a subset of Data.Generics.Uniplate.Direct (the @Uniplate@ type --- class and its utility plus constructor functions) --- ------------------------------------------------------------------------------ - -module Ideas.Common.Utils.Uniplate - ( -- * Uniplate type class and utility functions - Uniplate - , children, contexts, descend, descendM, holes, para - , rewrite, rewriteM, transform, transformM, uniplate, universe - -- * Instance constructors - , (|-), (|*), (||*), plate - ) where - -import Data.Generics.Uniplate.Direct 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 @@ -39,7 +39,6 @@ ) where import Control.Arrow -import Control.Monad import Data.Maybe import Ideas.Common.Classes import Ideas.Common.Id @@ -101,7 +100,7 @@ canonicalWithM :: IsView f => (b -> Maybe b) -> f a b -> a -> Maybe a canonicalWithM f view a = - match view a >>= liftM (build view) . f + match view a >>= fmap (build view) . f isCanonical :: (IsView f, Eq a) => f a b -> a -> Bool isCanonical = isCanonicalWith (==) 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 @@ -40,14 +40,14 @@ decodeType tp = case tp of Tag _ t -> decodeType t - Iso p t -> liftM (from p) (decodeType t) + Iso p t -> from p <$> decodeType t Pair t1 t2 -> do a <- decodeType t1 b <- decodeType t2 return (a, b) t1 :|: t2 -> - liftM Left (decodeType t1) `mplus` - liftM Right (decodeType t2) + (Left <$> decodeType t1) `mplus` + (Right <$> decodeType t2) Unit -> return () Const QCGen -> getQCGen Const Script -> getScript @@ -86,7 +86,7 @@ decodeLocation :: JSONDecoder a Location decodeLocation = decoderFor $ \json -> case json of - String s -> liftM toLocation (readM s) + String s -> toLocation <$> readM s _ -> fail "expecting a string for a location" decodeState :: JSONDecoder a (State a) @@ -126,7 +126,7 @@ case json of String p | p ~= "noprefix" -> return (\_ _ -> noPrefix) - | otherwise -> liftM replayPaths (readPaths p) + | otherwise -> replayPaths <$> readPaths p _ -> fail "invalid prefixes" where x ~= y = filter isAlphaNum (map toLower x) == y @@ -145,14 +145,15 @@ decodeContext :: JSONDecoder a (Context a) decodeContext = do ex <- getExercise - liftM (inContext ex) decodeExpression + inContext ex <$> decodeExpression 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) + case hasJSONView ex of + Just v -> matchM v json + Nothing -> fail "JSON encoding not supported by exercise" f False ex json = case json of String s -> either fail return (parser ex s) 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 @@ -23,7 +23,7 @@ import Ideas.Common.Traversal.Navigator import Ideas.Encoding.Encoder import Ideas.Encoding.OpenMathSupport -import Ideas.Service.Request +import Ideas.Encoding.Request import Ideas.Service.State import Ideas.Service.Types import Ideas.Text.OpenMath.Object @@ -43,14 +43,14 @@ maybe (fail "unknown difficulty level") (return . g) (readDifficulty a) | otherwise -> decodeChild s (xmlDecoder t) - Iso p t -> liftM (from p) (xmlDecoder t) + Iso p t -> from p <$> xmlDecoder t Pair t1 t2 -> do x <- xmlDecoder t1 y <- xmlDecoder t2 return (x, y) t1 :|: t2 -> - liftM Left (xmlDecoder t1) `mplus` - liftM Right (xmlDecoder t2) + (Left <$> xmlDecoder t1) `mplus` + (Right <$> xmlDecoder t2) Unit -> return () Const ctp -> case ctp of @@ -112,7 +112,7 @@ locRef = makeRef "location" case locRef ? env of Just s -> maybe (fail "invalid location") return $ do - loc <- liftM toLocation (readM s) + loc <- toLocation <$> readM s navigateTo loc (deleteRef locRef ctx) Nothing -> return ctx @@ -159,8 +159,7 @@ decodeConfiguration :: XMLDecoder a StrategyCfg decodeConfiguration = decodeChild "configuration" $ decoderFor $ \xml -> - liftM mconcat $ - mapM decodeAction (children xml) + mconcat <$> mapM decodeAction (children xml) where decodeAction item = do guard (null (children item)) @@ -170,7 +169,7 @@ decodeArgEnvironment :: XMLDecoder a Environment decodeArgEnvironment = decoderFor $ - liftM makeEnvironment . mapM (decodeBinding //) . findChildren "argument" + fmap makeEnvironment . mapM (decodeBinding //) . findChildren "argument" decodeBinding :: XMLDecoder a Binding decodeBinding = decoderFor $ \xml -> 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 @@ -14,12 +14,14 @@ module Ideas.Encoding.Encoder ( -- * Converter type class Converter(..) - , getExercise, getQCGen, getScript, getRequest + , getExercise, getBaseUrl, getQCGen, getScript, getRequest , withExercise, withOpenMath, withJSONTerm, (//) - -- * JSON terms - , termToJSON, jsonToTerm, jsonTermView - -- * Options - , Options, simpleOptions, makeOptions + -- * JSON support + , hasJSONView, addJSONView, jsonEncoding + , termToJSON, jsonToTerm + -- * Latex support + , hasLatexEncoding, latexPrinter, latexPrinterContext + , latexEncoding, latexEncodingWith -- * Encoder datatype , Encoder, TypedEncoder , makeEncoder, encoderFor, exerciseEncoder @@ -35,14 +37,15 @@ import Control.Applicative as Export hiding (Const) import Control.Arrow as Export import Control.Monad +import Data.Maybe 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.Encoding.Options +import Ideas.Encoding.Request +import Ideas.Service.FeedbackScript.Parser (Script) import Ideas.Service.Types import Ideas.Text.JSON hiding (String) +import Ideas.Text.Latex import Ideas.Text.XML import Test.QuickCheck.Random import qualified Control.Category as C @@ -53,14 +56,18 @@ -- Converter type class class Converter f where - fromOptions :: (Options a -> t) -> f a s t - run :: Monad m => f a s t -> Options a -> s -> m t + fromExercise :: (Exercise a -> t) -> f a s t + fromOptions :: (Options -> t) -> f a s t + run :: Monad m => f a s t -> Exercise a -> Options -> s -> m t getExercise :: Converter f => f a s (Exercise a) -getExercise = fromOptions exercise +getExercise = fromExercise id +getBaseUrl :: Converter f => f a s String +getBaseUrl = fromOptions (fromMaybe "http://ideas.cs.uu.nl/" . baseUrl) + getQCGen :: Converter f => f a s QCGen -getQCGen = fromOptions qcGen +getQCGen = fromOptions (fromMaybe (mkQCGen 0) . qcGen) getScript :: Converter f => f a s Script getScript = fromOptions script @@ -72,19 +79,32 @@ withExercise = (getExercise >>=) withOpenMath :: (Converter f, Monad (f a s)) => (Bool -> f a s t) -> f a s t -withOpenMath = (liftM useOpenMath getRequest >>=) +withOpenMath = (fmap useOpenMath getRequest >>=) withJSONTerm :: (Converter f, Monad (f a s)) => (Bool -> f a s t) -> f a s t -withJSONTerm = (liftM useJSONTerm getRequest >>=) +withJSONTerm = (fmap 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 + opts <- fromOptions id + ex <- getExercise + run p ex opts a ------------------------------------------------------------------- -- JSON terms +jsonProperty :: Id +jsonProperty = describe "Support for JSON encoding" $ newId "json" + +hasJSONView :: Exercise a -> Maybe (View JSON a) +hasJSONView = getPropertyF jsonProperty + +addJSONView :: View JSON a -> Exercise a -> Exercise a +addJSONView = setPropertyF jsonProperty + +jsonEncoding :: InJSON a => Exercise a -> Exercise a +jsonEncoding = addJSONView (makeView fromJSON toJSON) + termToJSON :: Term -> JSON termToJSON term = case term of @@ -120,55 +140,44 @@ 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, objectSymbol :: Symbol nullSymbol = newSymbol "null" objectSymbol = newSymbol "object" ------------------------------------------------------------------- --- Options +-- Latex support -data Options a = Options - { exercise :: Exercise a -- the current exercise - , request :: Request -- meta-information about the request - , qcGen :: QCGen -- random number generator - , script :: Script -- feedback script - } +latexProperty :: Id +latexProperty = describe "Support for LaTeX encoding" $ newId "latex" -simpleOptions :: Exercise a -> Options a -simpleOptions ex = - let req = emptyRequest {encoding = [EncHTML]} - gen = mkQCGen 0 - in Options ex req gen mempty +newtype F a = F { unF :: a -> Latex } -makeOptions :: DomainReasoner -> Request -> IO (Some Options) -makeOptions dr req = do - Some ex <- - case exerciseId req of - Just code -> findExercise dr code - Nothing -> return (Some emptyExercise) +getF :: Exercise a -> Maybe (F a) +getF = getPropertyF latexProperty - scr <- case feedbackScript req of - Just s -> parseScriptSafe s - Nothing - | getId ex == mempty -> return mempty - | otherwise -> defaultScript dr (getId ex) - gen <- maybe newQCGen (return . mkQCGen) (randomSeed req) - return $ Some Options - { exercise = ex - , request = req - , qcGen = gen - , script = scr - } +hasLatexEncoding :: Exercise a -> Bool +hasLatexEncoding = isJust . getF +-- | Uses exercise pretty-printer in case latex encoding is missing. +latexPrinter :: Exercise a -> a -> Latex +latexPrinter ex = maybe (toLatex . prettyPrinter ex) unF (getF ex) + +-- | Uses exercise pretty-printer in case latex encoding is missing. +latexPrinterContext :: Exercise a -> Context a -> Latex +latexPrinterContext ex ctx = + let def = toLatex (prettyPrinterContext ex ctx) + in fromMaybe def (unF <$> getF ex <*> fromContext ctx) + +latexEncoding :: ToLatex a => Exercise a -> Exercise a +latexEncoding = latexEncodingWith toLatex + +latexEncodingWith :: (a -> Latex) -> Exercise a -> Exercise a +latexEncodingWith = setPropertyF latexProperty . F + ------------------------------------------------------------------- -- Encoder datatype -newtype Encoder a s t = Enc { runEnc :: Options a -> s -> Error t } +newtype Encoder a s t = Enc { runEnc :: (Exercise a, Options) -> s -> Error t } type TypedEncoder a = Encoder a (TypedValue (Type a)) @@ -180,32 +189,35 @@ arr f = Enc $ \_ -> return . f first f = Enc $ \xs (a, b) -> runEnc f xs a >>= \c -> return (c, b) +instance Functor (Encoder a s) where + fmap f p = Enc $ \xs s -> f <$> runEnc p xs s + +instance Applicative (Encoder a s) where + pure a = Enc $ \_ _ -> return a + p <*> q = Enc $ \xs s -> do + f <- runEnc p xs s + f <$> runEnc q xs s + instance Alternative (Encoder a s) where - empty = mzero - (<|>) = mplus + empty = fail "Encoder: emptu" + p <|> q = Enc $ \xs s -> + runEnc p xs s <|> runEnc q xs s instance Monad (Encoder a s) where - return a = Enc $ \_ _ -> return a + return = pure fail s = Enc $ \_ _ -> fail s p >>= f = Enc $ \xs s -> do a <- runEnc p xs s runEnc (f a) xs s instance MonadPlus (Encoder a s) where - mzero = fail "Decoder: mzero" - mplus p q = Enc $ \xs s -> - runEnc p xs s `mplus` runEnc q xs s - -instance Functor (Encoder a s) where - fmap = liftM - -instance Applicative (Encoder a s) where - pure = return - (<*>) = liftM2 ($) + mzero = fail "Encoder: mzero" + mplus = (<|>) instance Converter Encoder where - fromOptions f = Enc $ \xs _ -> return (f xs) - run f xs = runErrorM . runEnc f xs + fromExercise f = Enc $ \(ex, _) _ -> return (f ex) + fromOptions f = Enc $ \(_, opts) _ -> return (f opts) + run f ex opts = runErrorM . runEnc f (ex, opts) instance Monoid t => Monoid (Encoder a s t) where mempty = pure mempty @@ -215,7 +227,7 @@ n .=. s = pure (n .=. s) unescaped = pure . unescaped builder = pure . builder - tag = liftA . tag + tag = fmap . tag makeEncoder :: (s -> t) -> Encoder a s t makeEncoder = arr @@ -242,12 +254,25 @@ ------------------------------------------------------------------- -- Decoder datatype -newtype Decoder a s t = Dec { runDec :: Options a -> s -> Error (t, s) } +newtype Decoder a s t = Dec { runDec :: (Exercise a, Options) -> s -> Error (t, s) } type TypedDecoder a s = forall t . Type a t -> Decoder a s t +instance Functor (Decoder a s) where + fmap f p = Dec $ \xs s -> mapFirst f <$> runDec p xs s + +instance Applicative (Decoder a s) where + pure a = Dec $ \_ s -> return (a, s) + p <*> q = Dec $ \xs s1 -> do + (f, s2) <- runDec p xs s1 + mapFirst f <$> runDec q xs s2 + +instance Alternative (Decoder a s) where + empty = fail "Decoder: empty" + p <|> q = Dec $ \xs s -> runDec p xs s <|> runDec q xs s + instance Monad (Decoder a s) where - return a = Dec $ \_ s -> return (a, s) + return = pure fail s = Dec $ \_ _ -> fail s p >>= f = Dec $ \xs s1 -> do (a, s2) <- runDec p xs s1 @@ -255,19 +280,7 @@ instance MonadPlus (Decoder a s) where mzero = fail "Decoder: mzero" - mplus p q = Dec $ \xs s -> - runDec p xs s `mplus` runDec q xs s - -instance Functor (Decoder a s) where - fmap = liftM - -instance Applicative (Decoder a s) where - pure = return - (<*>) = liftM2 ($) - -instance Alternative (Decoder a s) where - empty = fail "Decoder: empty" - (<|>) = mplus + mplus = (<|>) get :: Decoder a s s get = Dec $ \_ s -> return (s, s) @@ -276,8 +289,9 @@ put s = Dec $ \_ _ -> return ((), s) instance Converter Decoder where - fromOptions f = Dec $ \xs s -> return (f xs, s) - run f xs = liftM fst . runErrorM . runDec f xs + fromExercise f = Dec $ \(ex, _) s -> return (f ex, s) + fromOptions f = Dec $ \(_, opts) s -> return (f opts, s) + run f ex opts = fmap fst . runErrorM . runDec f (ex, opts) split :: (s -> Either String (t, s)) -> Decoder a s t split f = get >>= either fail (\(a, s2) -> put s2 >> return a) . f @@ -303,28 +317,32 @@ newtype Error a = Error { runError :: Either String a } instance Functor Error where - fmap = (<$>) + fmap f = Error . fmap f . runError instance Applicative Error where - pure = return - (<*>) = ap + pure = Error . Right + p <*> q = Error $ + case (runError p, runError q) of + (Left s, _) -> Left s + (_, Left s) -> Left s + (Right f, Right x) -> Right (f x) instance Alternative Error where - empty = mzero - (<|>) = mplus + empty = Error (Left "empty") + p <|> q = Error $ + case (runError p, runError q) of + (Right a, _) -> Right a + (_, Right a) -> Right a + (Left s, _) -> Left s instance Monad Error where fail = Error . Left - return = Error . Right + return = pure m >>= f = Error $ either Left (runError . f) (runError m) instance MonadPlus Error where - mzero = fail "mzero" - mplus p q = Error $ - case (runError p, runError q) of - (Right a, _) -> Right a - (_, Right a) -> Right a - (Left s, _) -> Left s + mzero = fail "mzero" + mplus = (<|>) runErrorM :: Monad m => Error a -> m a runErrorM = either fail return . runError 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 @@ -13,7 +13,7 @@ -- ----------------------------------------------------------------------------- -module Ideas.Encoding.EncoderHTML (htmlEncoder, htmlEncoderAt) where +module Ideas.Encoding.EncoderHTML (htmlEncoder) where import Data.Char import Data.List @@ -21,40 +21,38 @@ import Data.Ord import Ideas.Common.Library hiding (alternatives) import Ideas.Common.Strategy.Symbol -import Ideas.Common.Utils -import Ideas.Common.Utils.TestSuite import Ideas.Encoding.Encoder import Ideas.Encoding.LinkManager +import Ideas.Encoding.Request import Ideas.Encoding.RulePresenter import Ideas.Encoding.RulesInfo import Ideas.Encoding.StrategyInfo import Ideas.Service.BasicServices import Ideas.Service.Diagnose import Ideas.Service.DomainReasoner -import Ideas.Service.Request import Ideas.Service.State import Ideas.Service.Types import Ideas.Text.HTML import Ideas.Text.OpenMath.FMP import Ideas.Text.OpenMath.Object import Ideas.Text.XML +import Ideas.Utils.TestSuite import System.IO.Unsafe type HTMLEncoder a t = Encoder a t HTMLBuilder htmlEncoder :: DomainReasoner -> TypedEncoder a HTMLPage -htmlEncoder = htmlEncoderAt 0 - -htmlEncoderAt :: Int -> DomainReasoner -> TypedEncoder a HTMLPage -htmlEncoderAt n dr = do - req <- getRequest - let lm = f (maybe staticLinks dynamicLinks (cgiBinary req)) - f = if n==0 then id else linksUp n - makePage lm dr <$> encodeType lm dr +htmlEncoder dr = do + req <- getRequest + base <- getBaseUrl + let lm = makeLinkManager base (fromMaybe "" (cgiBinary req)) + ex <- getExercise + makePage lm dr ex <$> encodeType lm dr -makePage :: LinkManager -> DomainReasoner -> HTMLBuilder -> HTMLPage -makePage lm dr a = +makePage :: LinkManager -> DomainReasoner -> Exercise a -> HTMLBuilder -> HTMLPage +makePage lm dr ex a = addCSS (urlForCSS lm "ideas.css") $ + (if hasLatexEncoding ex then addScript mathJaxUrl else id) $ htmlPage "Ideas: documentation pages" $ mconcat [ divClass "page-header" $ mconcat [ divClass "ideas-logo" space @@ -67,6 +65,9 @@ , divClass "page-footer" $ string (fullVersion dr) ] + where + mathJaxUrl = + "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-MML-AM_CHTML" encodeType :: LinkManager -> DomainReasoner -> HTMLEncoder a (TypedValue (Type a)) encodeType lm dr = @@ -234,9 +235,7 @@ ] | isJust (randomExercise ex) ] ++ - [ para $ submitStateInfo lm ex - | not (isStatic lm) - ] + [ para $ submitStateInfo lm ex ] ] where generalInfo ex = keyValueTable @@ -416,15 +415,14 @@ encodeExampleList lm = exerciseEncoder $ \ex pairs -> mconcat $ h2 "Examples" : [ h3 (s ++ " (" ++ show (length xs) ++ ")") - <> (if isStatic lm then ul else mconcat) (map (make ex) xs) + <> mconcat (map (make ex) xs) | (_, s, xs) <- orderedGroupsWith show fst pairs ] where make ex (_, x) = para $ - munless (isStatic lm) ( - let st = emptyStateContext ex x - in spanClass "statelink" $ linkToState lm st $ external lm) - <> spanClass "term" (string (prettyPrinterContext ex x)) + ( let st = emptyStateContext ex x + in spanClass "statelink" $ linkToState lm st $ external lm) + <> htmlContext False ex x external :: BuildXML a => LinkManager -> a external lm = element "img" @@ -457,23 +455,30 @@ , showEnv env1 -- local environment , showEnv env2 -- global environment (diff) ] - textLines = mconcat . intersperse br . map string . lines - forTerm a = - divClass "term" $ textLines $ prettyPrinterContext ex a + forTerm = htmlContext True ex in htmlDerivationWith before forStep forTerm (diffEnvironment d) htmlState :: LinkManager -> HTMLEncoder a (State a) htmlState lm = makeEncoder $ \state -> para $ divClass "state" $ stateLink lm state - <> divClass "term" (string $ prettyPrinterContext (exercise state) (stateContext state)) + <> htmlContext True (exercise state) (stateContext state) <> string "ready: " <> bool (finished state) +htmlContext :: Bool -> Exercise a -> Context a -> HTMLBuilder +htmlContext useDiv ex = f "term" . textLines . printer + where + textLines = mconcat . intersperse br . map string . lines + f = if useDiv then divClass else spanClass + + inline s = "\\(" ++ s ++ "\\)" + printer + | hasLatexEncoding ex = inline . show . latexPrinterContext ex + | otherwise = prettyPrinterContext ex + stateLink :: LinkManager -> State a -> HTMLBuilder -stateLink lm st - | isStatic lm = mempty - | otherwise = - spanClass "derivation-statelink" $ linkToState lm st $ external lm +stateLink lm st = + spanClass "derivation-statelink" $ linkToState lm st $ external lm encodeState :: LinkManager -> DomainReasoner -> HTMLEncoder a (State a) encodeState lm dr = 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 @@ -17,11 +17,11 @@ import Data.Maybe import Ideas.Common.Library hiding (exerciseId) -import Ideas.Common.Utils (Some(..), distinct) import Ideas.Encoding.Encoder hiding (symbol) import Ideas.Service.State import Ideas.Service.Types hiding (String) import Ideas.Text.JSON +import Ideas.Utils.Prelude (distinct) import qualified Ideas.Service.Diagnose as Diagnose import qualified Ideas.Service.Submit as Submit import qualified Ideas.Service.Types as Tp @@ -60,7 +60,7 @@ tupleList (p ::: Tp.Pair t1 t2) = tupleList (fst p ::: t1) ++ tupleList (snd p ::: t2) tupleList (x ::: Tag s t) - | s `elem` ["Message"] = tupleList (x ::: t) + | s == "Message" = tupleList (x ::: t) tupleList (ev ::: (t1 :|: t2)) = either (\x -> tupleList (x ::: t1)) (\x -> tupleList (x ::: t2)) ev @@ -94,12 +94,8 @@ encodeContext :: JSONEncoder a (Context a) 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 + f True ex = fromMaybe Null . liftA2 build (hasJSONView ex) . fromContext + f False ex = String . prettyPrinterContext ex encodeState :: JSONEncoder a (State a) encodeState = encoderFor $ \st -> @@ -187,7 +183,7 @@ Diagnose.Unknown b st -> make "unknown" [fromReady b, fromState st] where - make s = liftA (\xs -> Object [(s, Array xs)]) . sequence + make s = fmap (\xs -> Object [(s, Array xs)]) . sequence fromEnv env = jsonEncoder // (env ::: tEnvironment) fromRule r = pure (toJSON (showId r)) fromMaybeRule mr = pure (maybe Null (toJSON . showId) mr) @@ -208,11 +204,12 @@ jsonTuple :: [JSON] -> JSON jsonTuple xs = - case mapM f xs of + case catMaybes <$> mapM f xs of Just ys | distinct (map fst ys) -> Object ys _ -> Array xs where - f (Object [p]) = Just p + f (Object [p]) = Just (Just p) + f Null = Just Nothing f _ = Nothing ruleShortInfo :: Rule a -> JSON 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 @@ -21,8 +21,7 @@ import Data.Char import Data.Maybe import Data.Monoid -import Ideas.Common.Library hiding (exerciseId, (:=), alternatives) -import Ideas.Common.Utils (Some(..)) +import Ideas.Common.Library hiding (exerciseId, alternatives) import Ideas.Encoding.Encoder import Ideas.Encoding.OpenMathSupport import Ideas.Encoding.RulesInfo (rulesInfoXML) 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 @@ -15,7 +15,8 @@ import Ideas.Common.Library import Ideas.Encoding.Encoder -import Ideas.Main.Logging +import Ideas.Encoding.Logging +import Ideas.Encoding.Options import Ideas.Service.Diagnose import Ideas.Service.Types @@ -36,16 +37,16 @@ [] -> return () hd:_ -> changeLog logRef (f hd) -evalService :: LogRef -> Options a -> Evaluator a b c -> Service -> b -> IO c -evalService logRef opts f srv b = do - res <- eval opts f b (serviceFunction srv) +evalService :: LogRef -> Exercise a -> Options -> Evaluator a b c -> Service -> b -> IO c +evalService logRef ex opts f srv b = do + res <- eval ex opts f b (serviceFunction srv) logType logRef res tState addState logType logRef res tRule $ \rl r -> r {ruleid = showId rl} logType logRef res tDiagnosis $ \d r -> r {serviceinfo = show d} return (evalResult res) -eval :: Options a -> Evaluator a b c -> b -> TypedValue (Type a) -> IO (EvalResult a c) -eval opts (Evaluator dec enc) b = rec +eval :: Exercise a -> Options -> Evaluator a b c -> b -> TypedValue (Type a) -> IO (EvalResult a c) +eval ex opts (Evaluator dec enc) b = rec where rec tv@(val ::: tp) = case tp of @@ -56,7 +57,7 @@ t1 :-> t2 :-> t3 -> rec (uncurry val ::: Pair t1 t2 :-> t3) t1 :-> t2 -> do - a <- run (dec t1) opts b + a <- run (dec t1) ex opts b res <- rec (val a ::: t2) return res { inputValues = (a ::: t1) : inputValues res } -- perform IO @@ -64,5 +65,5 @@ a <- val rec (a ::: t) _ -> do - c <- run enc opts tv + c <- run enc ex opts tv return $ EvalResult [] tv c 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 @@ -14,9 +14,9 @@ ----------------------------------------------------------------------------- module Ideas.Encoding.LinkManager - ( LinkManager(..) - , dynamicLinks, stateToXML - , staticLinks, linksUp, pathLevel, () + ( LinkManager(..), makeLinkManager + , stateToXML + -- , pathLevel, () -- links to services and exercises , linkToIndex, linkToExercises, linkToServices, linkToService -- links to exercise information @@ -31,6 +31,7 @@ import Ideas.Common.Library import Ideas.Encoding.Encoder import Ideas.Encoding.EncoderXML +import Ideas.Encoding.Options import Ideas.Service.State import Ideas.Service.Types import Ideas.Text.HTML @@ -40,7 +41,6 @@ { urlForCSS :: String -> String , urlForImage :: String -> String , urlForRequest :: String - , isStatic :: Bool -- links to services and exercises , urlForIndex :: String , urlForExercises :: String @@ -130,12 +130,11 @@ --------------------------------------------------------------------- -- Dynamic links -dynamicLinks :: String -> LinkManager -dynamicLinks cgiBinary = LinkManager - { isStatic = False - , urlForRequest = prefix - , urlForCSS = ("http://ideas.cs.uu.nl/css/" ++) - , urlForImage = ("http://ideas.cs.uu.nl/images/" ++) +makeLinkManager :: String -> String -> LinkManager +makeLinkManager base cgiBinary = LinkManager + { urlForRequest = prefix + , urlForCSS = \s -> base ++ "css/" ++ s + , urlForImage = \s -> base ++ "images/" ++ s , urlForIndex = url $ simpleRequest "index" , urlForExercises = url $ simpleRequest "exerciselist" , urlForServices = url $ simpleRequest "servicelist" @@ -186,7 +185,7 @@ -- assume nothing goest wrong stateToXML :: State a -> XMLBuilder stateToXML st = fromMaybe (error "LinkManager: Invalid state") $ - run encodeState (simpleOptions (exercise st)) st + run encodeState (exercise st) optionHtml st linkWith :: (a -> String) -> a -> HTMLBuilder -> HTMLBuilder linkWith f = link . escapeInURL . f @@ -200,80 +199,4 @@ f '%' = "%25" f '#' = "%23" f ';' = "%3B" - f c = [c] - ---------------------------------------------------------------------- --- Static links - -staticLinks :: LinkManager -staticLinks = LinkManager - { isStatic = True - , urlForCSS = id - , urlForImage = id - , urlForRequest = "" - , -- links to services and exercises - urlForIndex = "index.html" - , urlForExercises = "exercises.html" - , urlForServices = "services.html" - , urlForService = \srv -> "services" idToFilePath srv - -- links to exercise information - , urlForExercise = idToFilePath - , urlForStrategy = idToFilePathWith "-strategy.html" - , urlForRules = idToFilePathWith "-rules.html" - , urlForExamples = idToFilePathWith "-examples.html" - , urlForDerivations = idToFilePathWith "-derivations.html" - , urlForRule = \ex r -> idToFilePathWith ("/" ++ showId r ++ ".html") ex - , urlForTestReport = idToFilePathWith "-testreport.html" - -- dynamic exercise information - , urlForRandomExample = \_ _ -> "" - -- dynamic state information - , urlForState = const "" - , urlForFirsts = const "" - , urlForApplications = const "" - , urlForDerivation = const "" - , urlForMicrosteps = const "" - } - -linksUp :: Int -> LinkManager -> LinkManager -linksUp n lm = lm - { isStatic = isStatic lm - -- links to services and exercises - , urlForIndex = f0 urlForIndex - , urlForExercises = f0 urlForExercises - , urlForServices = f0 urlForServices - , urlForService = f1 urlForService - -- links to exercise information - , urlForExercise = f1 urlForExercise - , urlForStrategy = f1 urlForStrategy - , urlForRules = f1 urlForRules - , urlForExamples = f1 urlForExamples - , urlForDerivations = f1 urlForDerivations - , urlForRule = f2 urlForRule - -- dynamic exercise information - , urlForRandomExample = f2 urlForRandomExample - -- dynamic state information - , urlForState = f1 urlForState - , urlForFirsts = f1 urlForFirsts - , urlForApplications = f1 urlForApplications - , urlForDerivation = f1 urlForDerivation - , urlForMicrosteps = f1 urlForMicrosteps - } - where - f0 g = pathUp n $ g lm - f1 g = pathUp n . g lm - f2 g x = pathUp n . g lm x - -pathUp :: Int -> FilePath -> FilePath -pathUp n file = concat (replicate n "../") ++ file - -pathLevel :: FilePath -> Int -pathLevel = length . filter (=='/') - -idToFilePath :: HasId a => a -> FilePath -idToFilePath = idToFilePathWith ".html" - -idToFilePathWith :: HasId a => String -> a -> FilePath -idToFilePathWith suffix a = foldr () (unqualified a ++ suffix) (qualifiers a) - -() :: String -> FilePath -> FilePath -x y = x ++ "/" ++ y + f c = [c] diff --git a/src/Ideas/Encoding/Logging.hs b/src/Ideas/Encoding/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Encoding/Logging.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Facilities to create a log database +-- +----------------------------------------------------------------------------- + +module Ideas.Encoding.Logging + ( Record(..), addRequest, addState + , LogRef, newLogRef, noLogRef, changeLog + , logEnabled, logRecord, printLog + ) where + +import Data.IORef +import Data.Maybe +import Data.Time +import Ideas.Encoding.Request (Request, Schema(..)) +import Ideas.Service.State +import qualified Ideas.Encoding.Request as R + +#ifdef DB +import Data.List +import Database.HDBC +import Database.HDBC.Sqlite3 (connectSqlite3) +#endif + +type Diff = NominalDiffTime +type Time = UTCTime + +-- | The Record datatype is based on the Ideas Request Logging Schema version 2. +data Record = Record + { -- request attributes + service :: String -- name of feedback service + , exerciseid :: String -- exercise identifier + , source :: String -- tool/learning environment that makes request + , script :: String -- name of feedback script (for textual feedback) + , requestinfo :: String -- additional information from client (only for logging) + -- request format + , dataformat :: String -- xml, json + , encoding :: String -- options for encoding (e.g. OpenMath, string) + , -- grouping requests + userid :: String -- user identifier (e.g. student number) + , sessionid :: String -- session identifier (grouping requests for one task) + , taskid :: String -- task identifier (default: start term) + -- meta-information + , time :: Time -- date and time of request + , responsetime :: Diff -- time needed for processing request + , ipaddress :: String -- IP address of client + , binary :: String -- name of (cgi) binary that is being executed + , version :: String -- version (and revision) information + , errormsg :: String -- internal error message (default: empty string) + -- service info + , serviceinfo :: String -- summary of reply (customized for each service) + , ruleid :: String -- rule identifier (customized for each service) + -- raw data + , input :: String -- raw input (request) + , output :: String -- raw output (reply) + } + deriving Show + +record :: Record +record = Record "" "" "" "" "" "" "" "" "" "" t0 0 "" "" "" "" "" "" "" "" + where t0 = UTCTime (toEnum 0) 0 + +makeRecord :: IO Record +makeRecord = do + now <- getCurrentTime + return record { time = now } + +-- | Add record information from the Request datatype +addRequest :: Request -> Record -> Record +addRequest req r = r + { service = maybe (service r) show (R.serviceId req) + , exerciseid = maybe (exerciseid r) show (R.exerciseId req) + , source = fromMaybe (source r) (R.source req) + , script = fromMaybe (script r) (R.feedbackScript req) + , requestinfo = fromMaybe (requestinfo r) (R.requestInfo req) + , dataformat = show (R.dataformat req) + , encoding = show (R.encoding req) + , binary = fromMaybe (binary r) (R.cgiBinary req) + } + +-- | Add record information from the state (userid, sessionid, taskid) +addState :: State a -> Record -> Record +addState st r = r + { userid = fromMaybe (userid r) (stateUser st) + , sessionid = fromMaybe (sessionid r) (stateSession st) + , taskid = fromMaybe (taskid r) (stateStartTerm st) + } + +--------------------------------------------------------------------- + +newtype LogRef = L { mref :: Maybe (IORef Record) } + +noLogRef :: LogRef +noLogRef = L Nothing + +newLogRef :: IO LogRef +newLogRef = do + r <- makeRecord + ref <- newIORef r + return (L (Just ref)) + +getRecord :: LogRef -> IO Record +getRecord = maybe (return record) readIORef . mref + +changeLog :: LogRef -> (Record -> Record) -> IO () +changeLog = maybe (\_ -> return ()) modifyIORef . mref + +printLog :: LogRef -> IO () +printLog logRef = do + putStrLn "-- log information" + getRecord logRef >>= print + +-------------------------------------------------------------------------------- + +logEnabled :: Bool +logRecord :: Schema -> LogRef -> IO () + +#ifdef DB +logEnabled = True +logRecord schema logRef = + case schema of + V1 -> connectSqlite3 "service.db" >>= logRecordWith V1 logRef + V2 -> connectSqlite3 "requests.db" >>= logRecordWith V2 logRef + NoLogging -> return () +#else +-- without logging +logEnabled = False +logRecord _ _ = return () +#endif + +-------------------------------------------------------------------------------- + +#ifdef DB +nameOfTable :: Schema -> String +nameOfTable V1 = "log" +nameOfTable _ = "requests" + +columnsInTable :: Schema -> Record -> [SqlValue] +columnsInTable V1 = values_v1 +columnsInTable _ = values_v2 + +values_v1 :: Record -> [SqlValue] +values_v1 r = + let get f = toSql (f r) + in [ get service, get exerciseid, get source, get dataformat, get encoding + , get input, get output, get ipaddress, get time, get responsetime + ] + +values_v2 :: Record -> [SqlValue] +values_v2 r = + let get f = toSql (f r) + in [ get service, get exerciseid, get source, get script, get requestinfo + , get dataformat, get encoding, get userid, get sessionid, get taskid + , get time, get responsetime, get ipaddress, get binary, get version + , get errormsg, get serviceinfo, get ruleid, get input, get output + ] + +logRecordWith :: IConnection c => Schema -> LogRef -> c -> IO () +logRecordWith schema logRef conn = do + -- calculate duration + r <- getRecord logRef + end <- getCurrentTime + let diff = diffUTCTime end (time r) + -- insert data into database + insertRecord schema r {responsetime = diff} conn + -- close the connection to the database + disconnect conn + `catchSql` \err -> + putStrLn $ "Error in logging to database: " ++ show err + +insertRecord :: IConnection c => Schema -> Record -> c -> IO () +insertRecord schema r conn = + let cols = columnsInTable schema r + pars = "(" ++ intercalate "," (replicate (length cols) "?") ++ ")" + stm = "INSERT INTO " ++ nameOfTable schema ++ " VALUES " ++ pars + in run conn stm cols >> commit conn +#endif 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 @@ -18,22 +18,22 @@ import Data.Char import Data.Maybe import Ideas.Common.Library hiding (exerciseId) -import Ideas.Common.Utils (Some(..), timedSeconds) import Ideas.Encoding.DecoderJSON -import Ideas.Encoding.Encoder (makeOptions) import Ideas.Encoding.EncoderJSON import Ideas.Encoding.Evaluator -import Ideas.Main.Logging (LogRef, changeLog, errormsg) +import Ideas.Encoding.Logging (LogRef, changeLog, errormsg) +import Ideas.Encoding.Options (Options, makeOptions, maxTime, cgiBin) +import Ideas.Encoding.Request import Ideas.Service.DomainReasoner -import Ideas.Service.Request import Ideas.Text.JSON +import Ideas.Utils.Prelude (timedSeconds) -processJSON :: Maybe Int -> Maybe String -> DomainReasoner -> LogRef -> String -> IO (Request, String, String) -processJSON maxTime cgiBin dr logRef input = do - json <- either fail return (parseJSON input) - req <- jsonRequest cgiBin json +processJSON :: Options -> DomainReasoner -> LogRef -> String -> IO (Request, String, String) +processJSON options dr logRef txt = do + json <- either fail return (parseJSON txt) + req <- jsonRequest options json resp <- jsonRPC json $ \fun arg -> - maybe id timedSeconds maxTime (myHandler dr logRef req fun arg) + maybe id timedSeconds (maxTime options) (myHandler options dr logRef req fun arg) unless (responseError resp == Null) $ changeLog logRef (\r -> r {errormsg = show (responseError resp)}) let f = if compactOutput req then compactJSON else show @@ -51,7 +51,7 @@ Array (hd:_) -> extractExerciseId hd _ -> fail "no code" where - p c = not (isAlphaNum c || isSpace c || c `elem` ".-") + p c = not (isAlphaNum c || isSpace c || c `elem` ".-_") addVersion :: String -> JSON -> JSON addVersion str json = @@ -61,32 +61,32 @@ where info = ("version", String str) -jsonRequest :: Monad m => Maybe String -> JSON -> m Request -jsonRequest cgiBin json = do +jsonRequest :: Monad m => Options -> JSON -> m Request +jsonRequest options json = do let exId = lookupM "params" json >>= extractExerciseId srv <- stringOption "method" json newId src <- stringOption "source" json id rinf <- stringOption "requestinfo" json id - seed <- stringOptionM "randomseed" json (defaultSeed cgiBin) (return . readM) + seed <- stringOptionM "randomseed" json (defaultSeed options) (return . readM) enc <- stringOptionM "encoding" json [] readEncoding - sch <- stringOptionM "logging" json Nothing (liftM Just . readSchema) - return emptyRequest + sch <- stringOptionM "logging" json Nothing (fmap Just . readSchema) + return mempty { serviceId = srv , exerciseId = exId , source = src - , cgiBinary = cgiBin + , cgiBinary = cgiBin options , requestInfo = rinf , logSchema = sch , randomSeed = seed - , dataformat = JSON + , dataformat = Just 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 +defaultSeed :: Options -> Maybe Int +defaultSeed options + | isJust (cgiBin options) = 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) @@ -98,11 +98,15 @@ Just _ -> fail $ "Invalid value for " ++ attr ++ " (expecting string)" Nothing -> return a -myHandler :: DomainReasoner -> LogRef -> Request -> RPCHandler -myHandler dr logRef request fun json = do +myHandler :: Options -> DomainReasoner -> LogRef -> Request -> RPCHandler +myHandler opt1 dr logRef request fun json = do srv <- findService dr (newId fun) - Some options <- makeOptions dr request - evalService logRef options jsonEvaluator srv json + Some ex <- case exerciseId request of + Just a -> findExercise dr a + Nothing -> return (Some emptyExercise) + opt2 <- makeOptions dr ex request + let options = opt1 <> opt2 + evalService logRef ex options jsonEvaluator srv json jsonEvaluator :: Evaluator a JSON JSON jsonEvaluator = Evaluator jsonDecoder jsonEncoder 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 @@ -16,25 +16,25 @@ import Control.Exception import Control.Monad -import Ideas.Common.Library hiding (exerciseId, (:=)) -import Ideas.Common.Utils (Some(..), timedSeconds) +import Ideas.Common.Library hiding (exerciseId) import Ideas.Encoding.DecoderXML -import Ideas.Encoding.Encoder (makeOptions) import Ideas.Encoding.EncoderHTML import Ideas.Encoding.EncoderXML import Ideas.Encoding.Evaluator -import Ideas.Main.Logging (LogRef, changeLog, errormsg) +import Ideas.Encoding.Logging (LogRef, changeLog, errormsg) +import Ideas.Encoding.Options (Options, makeOptions, maxTime, cgiBin) +import Ideas.Encoding.Request import Ideas.Service.DomainReasoner -import Ideas.Service.Request import Ideas.Text.HTML import Ideas.Text.XML +import Ideas.Utils.Prelude (timedSeconds) import System.IO.Error -processXML :: Maybe Int -> Maybe String -> DomainReasoner -> LogRef -> String -> IO (Request, String, String) -processXML maxTime cgiBin dr logRef input = do - xml <- either fail return (parseXML input) - req <- xmlRequest cgiBin xml - resp <- maybe id timedSeconds maxTime (xmlReply dr logRef req xml) +processXML :: Options -> DomainReasoner -> LogRef -> String -> IO (Request, String, String) +processXML options dr logRef txt = do + xml <- either fail return (parseXML txt) + req <- xmlRequest (cgiBin options) xml + resp <- maybe id timedSeconds (maxTime options) (xmlReply options dr logRef req xml) `catch` handler let showXML | compactOutput req = compactXML | otherwise = show @@ -52,23 +52,23 @@ in xml { attributes = attributes xml ++ info } xmlRequest :: Monad m => Maybe String -> XML -> m Request -xmlRequest cgiBin xml = do +xmlRequest ms xml = do unless (name xml == "request") $ fail "expected xml tag request" enc <- case findAttribute "encoding" xml of Just s -> readEncoding s Nothing -> return [] - return emptyRequest + return mempty { serviceId = newId <$> findAttribute "service" xml , exerciseId = extractExerciseId xml , source = findAttribute "source" xml - , cgiBinary = cgiBin + , cgiBinary = ms , requestInfo = findAttribute "requestinfo" xml , logSchema = findAttribute "logging" xml >>= readSchema , feedbackScript = findAttribute "script" xml - , randomSeed = defaultSeed cgiBin $ + , randomSeed = defaultSeed ms $ findAttribute "randomseed" xml >>= readM - , dataformat = XML + , dataformat = Just XML , encoding = enc } @@ -77,22 +77,27 @@ defaultSeed Nothing Nothing = Just 2805 -- magic number defaultSeed _ m = m -xmlReply :: DomainReasoner -> LogRef -> Request -> XML -> IO XML -xmlReply dr logRef request xml = do +xmlReply :: Options -> DomainReasoner -> LogRef -> Request -> XML -> IO XML +xmlReply opt1 dr logRef request xml = do srv <- case serviceId request of Just a -> findService dr a Nothing -> fail "No service" - Some options <- makeOptions dr request + Some ex <- case exerciseId request of + Just a -> findExercise dr a + Nothing -> return (Some emptyExercise) + opt2 <- makeOptions dr ex request + let options = opt1 <> opt2 + if htmlOutput request -- HTML evaluator - then liftM toXML $ evalService logRef options (htmlEvaluator dr) srv xml + then toXML <$> evalService logRef ex options (htmlEvaluator dr) srv xml -- xml evaluator - else liftM resultOk $ evalService logRef options xmlEvaluator srv xml + else resultOk <$> evalService logRef ex options xmlEvaluator srv xml extractExerciseId :: Monad m => XML -> m Id -extractExerciseId = liftM newId . findAttribute "exerciseid" +extractExerciseId = fmap newId . findAttribute "exerciseid" resultOk :: XMLBuilder -> XML resultOk body = makeXML "reply" $ 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 @@ -21,10 +21,10 @@ import Data.Char import Data.List import Ideas.Common.Library -import Ideas.Common.Utils.Uniplate import Ideas.Text.OpenMath.Dictionary.Arith1 import Ideas.Text.OpenMath.Dictionary.Fns1 import Ideas.Text.OpenMath.Object +import Ideas.Utils.Uniplate import qualified Ideas.Text.OpenMath.Dictionary.List1 as OM import qualified Ideas.Text.OpenMath.Symbol as OM @@ -72,8 +72,8 @@ OMI n -> return (TNum n) OMF a -> return (TFloat a) OMA xs -> case xs of - OMS s:ys | s == OM.listSymbol -> liftM TList (mapM rec ys) - | otherwise -> liftM (function (newSymbol s)) (mapM rec ys) + OMS s:ys | s == OM.listSymbol -> TList <$> mapM rec ys + | otherwise -> function (newSymbol s) <$> mapM rec ys _ -> fail "Invalid OpenMath object" OMBIND binder xs body -> rec (OMA (binder:map OMV xs++[body])) diff --git a/src/Ideas/Encoding/Options.hs b/src/Ideas/Encoding/Options.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Encoding/Options.hs @@ -0,0 +1,73 @@ +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Ideas.Encoding.Options + ( Options, makeOptions, optionBaseUrl + , script, request, qcGen, baseUrl, maxTime + , cgiBin, optionCgiBin, optionHtml + ) where + +import Control.Applicative +import Data.Monoid +import Ideas.Common.Library (Exercise, getId) +import Ideas.Encoding.Request +import Ideas.Service.DomainReasoner +import Ideas.Service.FeedbackScript.Parser (parseScriptSafe, Script) +import Test.QuickCheck.Random + +------------------------------------------------------------------- +-- Options + +cgiBin :: Options -> Maybe String +cgiBin = cgiBinary . request + +optionCgiBin :: String -> Options +optionCgiBin s = mempty {request = mempty {cgiBinary = Just s}} + +data Options = Options + { request :: Request -- meta-information about the request + , qcGen :: Maybe QCGen -- random number generator + , script :: Script -- feedback script + , baseUrl :: Maybe String -- for html-encoder's css and image files + , maxTime :: Maybe Int -- timeout for services, in seconds + } + +instance Monoid Options where + mempty = Options mempty Nothing mempty Nothing Nothing + mappend x y = Options + { request = request x <> request y + , qcGen = make qcGen + , script = script x <> script y + , baseUrl = make baseUrl + , maxTime = make maxTime + } + where + make f = f x <|> f y + +optionHtml :: Options +optionHtml = mempty + { request = mempty {encoding = [EncHTML]} } + +optionBaseUrl :: String -> Options +optionBaseUrl base = mempty {baseUrl = Just base} + +makeOptions :: DomainReasoner -> Exercise a -> Request -> IO Options +makeOptions dr ex req = do + gen <- maybe newQCGen (return . mkQCGen) (randomSeed req) + scr <- case feedbackScript req of + Just s -> parseScriptSafe s + Nothing -> defaultScript dr (getId ex) + return $ mempty + { request = req + , qcGen = Just gen + , script = scr + } diff --git a/src/Ideas/Encoding/Request.hs b/src/Ideas/Encoding/Request.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Encoding/Request.hs @@ -0,0 +1,130 @@ +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Ideas.Encoding.Request where + +import Control.Applicative +import Data.Char +import Data.List +import Data.Maybe +import Ideas.Common.Library hiding (exerciseId) +import Ideas.Utils.Prelude + +data Request = Request + { serviceId :: Maybe Id + , exerciseId :: Maybe Id + , source :: Maybe String + , feedbackScript :: Maybe String + , requestInfo :: Maybe String + , cgiBinary :: Maybe String + , logSchema :: Maybe Schema + , randomSeed :: Maybe Int + , dataformat :: Maybe DataFormat -- default: XML + , encoding :: [Encoding] + } + +instance Monoid Request where + mempty = Request Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing [] + mappend x y = Request + { serviceId = make serviceId + , exerciseId = make exerciseId + , source = make source + , feedbackScript = make feedbackScript + , requestInfo = make requestInfo + , cgiBinary = make cgiBinary + , logSchema = make logSchema + , randomSeed = make randomSeed + , dataformat = make dataformat + , encoding = encoding x <> encoding y + } + where + make f = f x <|> f y + +data Schema = V1 | V2 | NoLogging deriving (Show, Eq) + +getSchema :: Request -> Schema +getSchema = fromMaybe V1 . logSchema -- log schema V1 is the default + +readSchema :: Monad m => String -> m Schema +readSchema s0 + | s == "v1" = return V1 + | s == "v2" = return V2 + | s `elem` ["false", "no"] = return NoLogging + | otherwise = fail "Unknown schema" + where + s = map toLower (filter isAlphaNum s0) + +data DataFormat = XML | JSON + deriving Show -- needed for LoggingDatabase + +data Encoding = EncHTML -- html page as output + | EncOpenMath -- encode terms in OpenMath + | EncString -- encode terms as strings + | EncCompact -- compact ouput + | EncPretty -- pretty output + | EncJSON -- encode terms in JSON + deriving Eq + +instance Show Encoding where + showList xs rest = intercalate "+" (map show xs) ++ rest + show EncHTML = "html" + show EncOpenMath = "openmath" + show EncString = "string" + show EncCompact = "compact" + show EncPretty = "pretty" + show EncJSON = "json" + +htmlOutput :: Request -> Bool +htmlOutput = (EncHTML `elem`) . encoding + +compactOutput :: Request -> Bool +compactOutput req = + case (EncCompact `elem` xs, EncPretty `elem` xs) of + (True, False) -> True + (False, True) -> False + _ -> isJust (cgiBinary req) + where + xs = encoding req + +useOpenMath :: Request -> Bool +useOpenMath r = + case dataformat r of + Just JSON -> False + _ -> all (`notElem` encoding r) [EncString, EncHTML] + +useJSONTerm :: Request -> Bool +useJSONTerm r = + case dataformat r of + Just JSON -> EncJSON `elem` encoding r + _ -> False + +useLogging :: Request -> Bool +useLogging = (EncHTML `notElem`) . encoding + +discoverDataFormat :: Monad m => String -> m DataFormat +discoverDataFormat xs = + case dropWhile isSpace xs of + '<':_ -> return XML + '{':_ -> return JSON + _ -> fail "Unknown data format" + +readEncoding :: Monad m => String -> m [Encoding] +readEncoding = mapM (f . map toLower) . splitsWithElem '+' + where + f "html" = return EncHTML + f "openmath" = return EncOpenMath + 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/Encoding/RulePresenter.hs b/src/Ideas/Encoding/RulePresenter.hs --- a/src/Ideas/Encoding/RulePresenter.hs +++ b/src/Ideas/Encoding/RulePresenter.hs @@ -15,7 +15,6 @@ import Data.List import Data.Maybe import Ideas.Common.Library -import Ideas.Common.Utils (Some(..)) import Ideas.Text.HTML ruleToHTML :: Some Exercise -> Rule a -> HTMLBuilder 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 @@ -16,7 +16,6 @@ import Data.Char import Ideas.Common.Library -import Ideas.Common.Utils (Some(..)) import Ideas.Encoding.OpenMathSupport (toOMOBJ) import Ideas.Text.OpenMath.FMP import Ideas.Text.OpenMath.Object 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 @@ -14,10 +14,10 @@ module Ideas.Encoding.StrategyInfo (strategyToXML) where -import Ideas.Common.CyclicTree import Ideas.Common.Id import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Configuration +import Ideas.Common.Strategy.CyclicTree import Ideas.Common.Strategy.StrategyTree (StrategyTree) import Ideas.Text.XML diff --git a/src/Ideas/Main/BlackBoxTests.hs b/src/Ideas/Main/BlackBoxTests.hs deleted file mode 100644 --- a/src/Ideas/Main/BlackBoxTests.hs +++ /dev/null @@ -1,116 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Main.BlackBoxTests (blackBoxTests) where - -import Control.Monad -import Data.Char -import Data.List -import Ideas.Common.Utils (snd3) -import Ideas.Common.Utils.TestSuite -import Ideas.Encoding.ModeJSON -import Ideas.Encoding.ModeXML -import Ideas.Main.Logging -import Ideas.Service.DomainReasoner -import Ideas.Service.Request -import System.Directory -import System.IO -import qualified Data.Algorithm.Diff as Diff - --- Returns the number of tests performed -blackBoxTests :: DomainReasoner -> String -> IO TestSuite -blackBoxTests dr path = do - -- analyse content - xs0 <- getDirectoryContents path - let (xml, xs1) = partition (".xml" `isSuffixOf`) xs0 - (json, xs2) = partition (".json" `isSuffixOf`) xs1 - xs3 = map (path ) (filter ((/= ".") . take 1) xs2) - -- recursively visit subdirectories - subs <- filterM doesDirectoryExist xs3 - rest <- mapM (blackBoxTests dr) subs - return $ suite ("Directory " ++ simplerDirectory path) $ - [ doBlackBoxTest dr JSON (path x) - | x <- json - ] ++ - [ doBlackBoxTest dr XML (path x) - | x <- xml - ] ++ - rest - -doBlackBoxTest :: DomainReasoner -> DataFormat -> FilePath -> TestSuite -doBlackBoxTest dr format path = - assertMessageIO (stripDirectoryPart path) $ do - -- Comparing output with expected output - withFile path ReadMode $ \h1 -> do - hSetBinaryMode h1 True - txt <- hGetContents h1 - out <- case format of - JSON -> liftM snd3 (processJSON Nothing Nothing dr noLogRef txt) - XML -> liftM snd3 (processXML Nothing Nothing dr noLogRef txt) - withFile expPath ReadMode $ \h2 -> do - hSetBinaryMode h2 True - expt <- hGetContents h2 - -- Force evaluation of the result, to make sure that - -- all file handles are closed afterwards. - let list1 = prepare expt - list2 = prepare out - msg = unlines (path : diffs list1 list2) - if list1 == list2 then return mempty else do - force msg -- force evaluation of message before closing files - return (message msg) - where - expPath = baseOf path ++ ".exp" - baseOf = reverse . drop 1 . dropWhile (/= '.') . reverse - -force :: String -> IO () -force s | sum (map ord s) >= 0 = return () - | otherwise = error "force" - -prepare :: String -> [String] -prepare = filter (not . null) . lines . filter (/= '\r') . noVersion - where - noVersion s | "version\": \"" `isPrefixOf` s = - "version\": \"X" ++ dropWhile (/='"') (drop 11 s) - noVersion s | "version=\"" `isPrefixOf` s = - "version=\"X" ++ dropWhile (/='"') (drop 9 s) - noVersion (x:xs) = x:noVersion xs - noVersion [] = [] - -diffs :: [String] -> [String] -> [String] -diffs xs ys = concatMap f $ Diff.getDiff xs ys - where - f (Diff.First a) = ["- " ++ a] - f (Diff.Second a) = ["+ " ++ a] - f _ = [] - -simplerDirectory :: String -> String -simplerDirectory s - | "../" `isPrefixOf` s = simplerDirectory (drop 3 s) - | "test/" `isPrefixOf` s = simplerDirectory (drop 5 s) - | otherwise = s - -stripDirectoryPart :: String -> String -stripDirectoryPart = reverse . takeWhile (/= '/') . reverse - -() :: FilePath -> FilePath -> FilePath -x y = x ++ "/" ++ y - -{- -logicConfluence :: IO () -logicConfluence = reportTest "logic rules" (isConfluent f rs) - where - f = normalizeWith ops . normalFormWith ops rs - ops = map makeCommutative Logic.logicOperators - rwrs = Logic.logicRules \\ [Logic.ruleOrOverAnd, Logic.ruleCommOr, Logic.ruleCommAnd] - rs = [ r | RewriteRule r <- concatMap transformations rwrs ] - -- eqs = bothWays [ r | RewriteRule r <- concatMap transformations Logic.logicRules ] --} diff --git a/src/Ideas/Main/CmdLineOptions.hs b/src/Ideas/Main/CmdLineOptions.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Main/CmdLineOptions.hs @@ -0,0 +1,80 @@ +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Command-Line Options +-- +----------------------------------------------------------------------------- + +module Ideas.Main.CmdLineOptions + ( CmdLineOption(..), getCmdLineOptions + , versionText, helpText, shortVersion, fullVersion + ) where + +import Data.Maybe +import Ideas.Encoding.Logging (logEnabled) +import Ideas.Main.Revision +import System.Console.GetOpt +import System.Environment +import System.Exit + +data CmdLineOption + = Version | Help | PrintLog + | InputFile String | Test FilePath + | MakeScriptFor String | AnalyzeScript FilePath + deriving Eq + +header :: String +header = + "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++ + "Copyright 2016, Open Universiteit Nederland\n" ++ + versionText ++ + "\n\nUsage: ideas [OPTION] (by default, CGI protocol)\n" ++ + "\nOptions:" + +versionText :: String +versionText = + "version " ++ ideasVersion ++ ", revision " ++ ideasRevision ++ + ", logging " ++ (if logEnabled then "enabled" else "disabled") + +helpText :: String +helpText = usageInfo header options + +fullVersion :: String +fullVersion = "version " ++ ideasVersion ++ " (revision " + ++ ideasRevision ++ ", " ++ ideasLastChanged ++ ")" + +shortVersion :: String +shortVersion = ideasVersion ++ " (" ++ ideasRevision ++ ")" + +options :: [OptDescr CmdLineOption] +options = + [ Option [] ["version"] (NoArg Version) "show version number" + , Option "?" ["help"] (NoArg Help) "show options" + , Option "" ["print-log"] (NoArg PrintLog) "print log information (for debugging)" + , Option "f" ["file"] fileArg "use input FILE as request" + , Option "" ["test"] testArg "run tests on directory (default: 'test')" + , Option "" ["make-script"] makeScrArg "generate feedback script for exercise" + , Option "" ["analyze-script"] analyzeScrArg "analyze feedback script and report errors" + ] + +fileArg, testArg, makeScrArg, analyzeScrArg :: ArgDescr CmdLineOption +fileArg = ReqArg InputFile "FILE" +testArg = OptArg (Test . fromMaybe "test") "DIR" +makeScrArg = ReqArg MakeScriptFor "ID" +analyzeScrArg = ReqArg AnalyzeScript "FILE" + +getCmdLineOptions :: IO [CmdLineOption] +getCmdLineOptions = do + args <- getArgs + case getOpt Permute options args of + (flags, [], []) -> return flags + (_, _, errs) -> do + putStrLn (concat errs ++ helpText) + exitFailure 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 @@ -13,42 +13,45 @@ ----------------------------------------------------------------------------- module Ideas.Main.Default - ( defaultMain, defaultCGI + ( defaultMain, defaultMainWith, defaultCGI -- extra exports - , Some(..), serviceList, metaServiceList, Service + , serviceList, metaServiceList, Service , module Ideas.Service.DomainReasoner ) where import Control.Exception import Control.Monad import Data.Maybe -import Ideas.Common.Utils (Some(..)) -import Ideas.Common.Utils.TestSuite import Ideas.Encoding.ModeJSON (processJSON) import Ideas.Encoding.ModeXML (processXML) -import Ideas.Main.BlackBoxTests -import Ideas.Main.Documentation -import Ideas.Main.Options hiding (fullVersion) +import Ideas.Encoding.Options (Options, maxTime, optionCgiBin) +import Ideas.Encoding.Request +import Ideas.Main.CmdLineOptions hiding (fullVersion) import Ideas.Service.DomainReasoner import Ideas.Service.FeedbackScript.Analysis -import Ideas.Service.Request import Ideas.Service.ServiceList import Ideas.Service.Types (Service) +import Ideas.Utils.BlackBoxTests +import Ideas.Utils.TestSuite import Network.CGI import System.IO import System.IO.Error (ioeGetErrorString) -import qualified Ideas.Main.Logging as Log +import qualified Ideas.Encoding.Logging as Log +import qualified Ideas.Main.CmdLineOptions as Options defaultMain :: DomainReasoner -> IO () -defaultMain dr = do - flags <- getFlags - if null flags - then defaultCGI dr - else defaultCommandLine dr flags +defaultMain = defaultMainWith mempty +defaultMainWith :: Options -> DomainReasoner -> IO () +defaultMainWith options dr = do + cmdLineOptions <- getCmdLineOptions + if null cmdLineOptions + then defaultCGI options dr + else defaultCommandLine options (addVersion dr) cmdLineOptions + -- Invoked as a cgi binary -defaultCGI :: DomainReasoner -> IO () -defaultCGI dr = runCGI $ handleErrors $ do +defaultCGI :: Options -> DomainReasoner -> IO () +defaultCGI options dr = runCGI $ handleErrors $ do -- create a record for logging logRef <- liftIO Log.newLogRef -- query environment @@ -57,7 +60,7 @@ input <- inputOrDefault -- process request (req, txt, ctp) <- liftIO $ - process dr logRef (Just cgiBin) input + process (options <> optionCgiBin cgiBin) dr logRef input -- log request to database when (useLogging req) $ liftIO $ do Log.changeLog logRef $ \r -> Log.addRequest req r @@ -97,13 +100,13 @@ return (isJust maybeAcceptCT && not (null xs)) -- Invoked from command-line with flags -defaultCommandLine :: DomainReasoner -> [Flag] -> IO () -defaultCommandLine dr flags = do +defaultCommandLine :: Options -> DomainReasoner -> [CmdLineOption] -> IO () +defaultCommandLine options dr cmdLineOptions = do hSetBinaryMode stdout True - mapM_ doAction flags + mapM_ doAction cmdLineOptions where - doAction flag = - case flag of + doAction cmdLineOption = + case cmdLineOption of -- information Version -> putStrLn ("IDEAS, " ++ versionText) Help -> putStrLn helpText @@ -112,9 +115,9 @@ withBinaryFile file ReadMode $ \h -> do logRef <- liftIO Log.newLogRef input <- hGetContents h - (req, txt, _) <- process dr logRef Nothing input + (req, txt, _) <- process options dr logRef input putStrLn txt - when (PrintLog `elem` flags) $ do + when (PrintLog `elem` cmdLineOptions) $ do Log.changeLog logRef $ \r -> Log.addRequest req r { Log.ipaddress = "command-line" , Log.version = shortVersion @@ -124,25 +127,35 @@ Log.printLog logRef -- blackbox tests Test dir -> do - tests <- blackBoxTests dr dir + tests <- blackBoxTests (makeTestRunner dr) ["xml", "json"] dir result <- runTestSuiteResult True tests printSummary result - -- generate documentation pages - MakePages dir -> - makeDocumentation dr dir -- feedback scripts MakeScriptFor s -> makeScriptFor dr s AnalyzeScript file -> parseAndAnalyzeScript dr file PrintLog -> return () -process :: DomainReasoner -> Log.LogRef -> Maybe String -> String -> IO (Request, String, String) -process dr logRef cgiBin input = do +process :: Options -> DomainReasoner -> Log.LogRef -> String -> IO (Request, String, String) +process options dr logRef input = do format <- discoverDataFormat input - run format (Just 5) cgiBin dr logRef input + run format options {maxTime = Just 5} (addVersion dr) logRef input `catch` \ioe -> do let msg = "Error: " ++ ioeGetErrorString ioe Log.changeLog logRef (\r -> r { Log.errormsg = msg }) - return (emptyRequest, msg, "text/plain") + return (mempty, msg, "text/plain") where run XML = processXML - run JSON = processJSON + run JSON = processJSON + +makeTestRunner :: DomainReasoner -> String -> IO String +makeTestRunner dr input = do + (_, out, _) <- process mempty dr Log.noLogRef input + return out + +addVersion :: DomainReasoner -> DomainReasoner +addVersion dr = dr + { version = update version Options.shortVersion + , fullVersion = update fullVersion Options.fullVersion + } + where + update f s = if null (f dr) then s else f dr diff --git a/src/Ideas/Main/Documentation.hs b/src/Ideas/Main/Documentation.hs deleted file mode 100644 --- a/src/Ideas/Main/Documentation.hs +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Manages links to information --- ------------------------------------------------------------------------------ - -module Ideas.Main.Documentation (makeDocumentation) where - -import Control.Monad -import Ideas.Common.Library -import Ideas.Common.Utils -import Ideas.Encoding.Encoder (run, simpleOptions) -import Ideas.Encoding.EncoderHTML -import Ideas.Encoding.LinkManager -import Ideas.Service.BasicServices -import Ideas.Service.DomainReasoner -import Ideas.Service.Types -import Ideas.Text.HTML -import System.Directory -import System.FilePath (takeDirectory) - -makeDocumentation :: DomainReasoner -> String -> IO () -makeDocumentation dr dir = do - putStrLn "Generating index pages" - makeIndex urlForIndex (dr ::: tDomainReasoner) - makeIndex urlForExercises (exercises dr ::: tList tSomeExercise) - makeIndex urlForServices (services dr ::: tList tService) - putStrLn "Generating service pages" - forM_ (services dr) $ \srv -> - makeIndex (`urlForService` srv) (srv ::: tService) - putStrLn "Generating exercise pages" - forM_ (exercises dr) $ \(Some ex) -> do - makeEx ex urlForExercise (ex ::: tExercise) - makeEx ex urlForStrategy (toStrategy (strategy ex) ::: tStrategy) - makeEx ex urlForRules (ruleset ex ::: tList tRule) - makeEx ex urlForExamples (map (second (inContext ex)) (examples ex) ::: tList (tPair tDifficulty tContext)) - makeEx ex urlForDerivations (exampleDerivations ex ::: tError (tList (tDerivation (tPair tRule tEnvironment) tContext))) - forM_ (ruleset ex) $ \r -> - make ex (urlForRule lm ex r) (r ::: tRule) - where - lm = staticLinks - makeIndex f = make emptyExercise (f lm) - makeEx ex f = make ex (f lm ex) - make ex url tv = do - let enc = htmlEncoderAt (pathLevel url) dr - html <- run enc (simpleOptions ex) tv - safeWrite (dir url) (showHTML html) - -safeWrite :: FilePath -> String -> IO () -safeWrite filename txt = do - let dirpart = takeDirectory filename - unless (null dirpart) (createDirectoryIfMissing True dirpart) - putStrLn $ "- " ++ filename - writeFile filename txt diff --git a/src/Ideas/Main/Logging.hs b/src/Ideas/Main/Logging.hs deleted file mode 100644 --- a/src/Ideas/Main/Logging.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Facilities to create a log database --- ------------------------------------------------------------------------------ - -module Ideas.Main.Logging - ( Record(..), addRequest, addState - , LogRef, newLogRef, noLogRef, changeLog - , logEnabled, logRecord, printLog - ) where - -import Data.IORef -import Data.Maybe -import Data.Time -import Ideas.Service.Request (Request, Schema(..)) -import Ideas.Service.State -import qualified Ideas.Service.Request as R - -#ifdef DB -import Data.List -import Database.HDBC -import Database.HDBC.Sqlite3 (connectSqlite3) -#endif - -type Diff = NominalDiffTime -type Time = UTCTime - --- | The Record datatype is based on the Ideas Request Logging Schema version 2. -data Record = Record - { -- request attributes - service :: String -- name of feedback service - , exerciseid :: String -- exercise identifier - , source :: String -- tool/learning environment that makes request - , script :: String -- name of feedback script (for textual feedback) - , requestinfo :: String -- additional information from client (only for logging) - -- request format - , dataformat :: String -- xml, json - , encoding :: String -- options for encoding (e.g. OpenMath, string) - , -- grouping requests - userid :: String -- user identifier (e.g. student number) - , sessionid :: String -- session identifier (grouping requests for one task) - , taskid :: String -- task identifier (default: start term) - -- meta-information - , time :: Time -- date and time of request - , responsetime :: Diff -- time needed for processing request - , ipaddress :: String -- IP address of client - , binary :: String -- name of (cgi) binary that is being executed - , version :: String -- version (and revision) information - , errormsg :: String -- internal error message (default: empty string) - -- service info - , serviceinfo :: String -- summary of reply (customized for each service) - , ruleid :: String -- rule identifier (customized for each service) - -- raw data - , input :: String -- raw input (request) - , output :: String -- raw output (reply) - } - deriving Show - -record :: Record -record = Record "" "" "" "" "" "" "" "" "" "" t0 0 "" "" "" "" "" "" "" "" - where t0 = UTCTime (toEnum 0) 0 - -makeRecord :: IO Record -makeRecord = do - now <- getCurrentTime - return record { time = now } - --- | Add record information from the Request datatype -addRequest :: Request -> Record -> Record -addRequest req r = r - { service = maybe (service r) show (R.serviceId req) - , exerciseid = maybe (exerciseid r) show (R.exerciseId req) - , source = fromMaybe (source r) (R.source req) - , script = fromMaybe (script r) (R.feedbackScript req) - , requestinfo = fromMaybe (requestinfo r) (R.requestInfo req) - , dataformat = show (R.dataformat req) - , encoding = show (R.encoding req) - , binary = fromMaybe (binary r) (R.cgiBinary req) - } - --- | Add record information from the state (userid, sessionid, taskid) -addState :: State a -> Record -> Record -addState st r = r - { userid = fromMaybe (userid r) (stateUser st) - , sessionid = fromMaybe (sessionid r) (stateSession st) - , taskid = fromMaybe (taskid r) (stateStartTerm st) - } - ---------------------------------------------------------------------- - -newtype LogRef = L { mref :: Maybe (IORef Record) } - -noLogRef :: LogRef -noLogRef = L Nothing - -newLogRef :: IO LogRef -newLogRef = do - r <- makeRecord - ref <- newIORef r - return (L (Just ref)) - -getRecord :: LogRef -> IO Record -getRecord = maybe (return record) readIORef . mref - -changeLog :: LogRef -> (Record -> Record) -> IO () -changeLog = maybe (\_ -> return ()) modifyIORef . mref - -printLog :: LogRef -> IO () -printLog logRef = do - putStrLn "-- log information" - getRecord logRef >>= print - --------------------------------------------------------------------------------- - -logEnabled :: Bool -logRecord :: Schema -> LogRef -> IO () - -#ifdef DB -logEnabled = True -logRecord schema logRef = - case schema of - V1 -> connectSqlite3 "service.db" >>= logRecordWith V1 logRef - V2 -> connectSqlite3 "requests.db" >>= logRecordWith V2 logRef - NoLogging -> return () -#else --- without logging -logEnabled = False -logRecord _ _ = return () -#endif - --------------------------------------------------------------------------------- - -#ifdef DB -nameOfTable :: Schema -> String -nameOfTable V1 = "log" -nameOfTable _ = "requests" - -columnsInTable :: Schema -> Record -> [SqlValue] -columnsInTable V1 = values_v1 -columnsInTable _ = values_v2 - -values_v1 :: Record -> [SqlValue] -values_v1 r = - let get f = toSql (f r) - in [ get service, get exerciseid, get source, get dataformat, get encoding - , get input, get output, get ipaddress, get time, get responsetime - ] - -values_v2 :: Record -> [SqlValue] -values_v2 r = - let get f = toSql (f r) - in [ get service, get exerciseid, get source, get script, get requestinfo - , get dataformat, get encoding, get userid, get sessionid, get taskid - , get time, get responsetime, get ipaddress, get binary, get version - , get errormsg, get serviceinfo, get ruleid, get input, get output - ] - -logRecordWith :: IConnection c => Schema -> LogRef -> c -> IO () -logRecordWith schema logRef conn = do - -- calculate duration - r <- getRecord logRef - end <- getCurrentTime - let diff = diffUTCTime end (time r) - -- insert data into database - insertRecord schema r {responsetime = diff} conn - -- close the connection to the database - disconnect conn - `catchSql` \err -> - putStrLn $ "Error in logging to database: " ++ show err - -insertRecord :: IConnection c => Schema -> Record -> c -> IO () -insertRecord schema r conn = - let cols = columnsInTable schema r - pars = "(" ++ intercalate "," (replicate (length cols) "?") ++ ")" - stm = "INSERT INTO " ++ nameOfTable schema ++ " VALUES " ++ pars - in run conn stm cols >> commit conn -#endif diff --git a/src/Ideas/Main/Options.hs b/src/Ideas/Main/Options.hs deleted file mode 100644 --- a/src/Ideas/Main/Options.hs +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Options and command-line flags for services --- ------------------------------------------------------------------------------ - -module Ideas.Main.Options - ( Flag(..), getFlags - , versionText, helpText, shortVersion, fullVersion - ) where - -import Data.Maybe -import Ideas.Main.Logging (logEnabled) -import Ideas.Main.Revision -import System.Console.GetOpt -import System.Environment -import System.Exit - -data Flag = Version | Help | PrintLog - | InputFile String - | MakePages FilePath | Test FilePath - | MakeScriptFor String | AnalyzeScript FilePath - - deriving Eq - -header :: String -header = - "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++ - "Copyright 2016, Open Universiteit Nederland\n" ++ - versionText ++ - "\n\nUsage: ideas [OPTION] (by default, CGI protocol)\n" ++ - "\nOptions:" - -versionText :: String -versionText = - "version " ++ ideasVersion ++ ", revision " ++ ideasRevision ++ - ", logging " ++ (if logEnabled then "enabled" else "disabled") - -helpText :: String -helpText = usageInfo header options - -fullVersion :: String -fullVersion = "version " ++ ideasVersion ++ " (revision " - ++ ideasRevision ++ ", " ++ ideasLastChanged ++ ")" - -shortVersion :: String -shortVersion = ideasVersion ++ " (" ++ ideasRevision ++ ")" - -options :: [OptDescr Flag] -options = - [ Option [] ["version"] (NoArg Version) "show version number" - , Option "?" ["help"] (NoArg Help) "show options" - , Option "" ["print-log"] (NoArg PrintLog) "print log information (for debugging)" - , Option "f" ["file"] fileArg "use input FILE as request" - , Option "" ["make-pages"] pagesArg "generate pages for exercises and services" - , Option "" ["test"] testArg "run tests on directory (default: 'test')" - , Option "" ["make-script"] makeScrArg "generate feedback script for exercise" - , Option "" ["analyze-script"] analyzeScrArg "analyze feedback script and report errors" - ] - -fileArg, testArg, pagesArg, makeScrArg, analyzeScrArg :: ArgDescr Flag -fileArg = ReqArg InputFile "FILE" -testArg = OptArg (Test . fromMaybe "test") "DIR" -pagesArg = OptArg (MakePages . fromMaybe "docs") "DIR" -makeScrArg = ReqArg MakeScriptFor "ID" -analyzeScrArg = ReqArg AnalyzeScript "FILE" - -getFlags :: IO [Flag] -getFlags = do - args <- getArgs - case getOpt Permute options args of - (flags, [], []) -> return flags - (_, _, errs) -> do - putStrLn (concat errs ++ helpText) - exitFailure 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.5" +ideasVersion = "1.6" ideasRevision :: String -ideasRevision = "cfe6d70796113f07095f803981e1d2cc222d4b8e" +ideasRevision = "893c5ef99623f5741cb221bd14b52c17d133cc69" ideasLastChanged :: String -ideasLastChanged = "Thu May 26 20:50:01 2016 +0200" +ideasLastChanged = "Wed Dec 14 14:07:10 2016 +0100" 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 @@ -13,7 +13,7 @@ module Ideas.Service.BasicServices ( -- * Basic Services stepsremaining, findbuggyrules, allfirsts, solution - , onefirst, applicable, allapplications, apply, generate, create + , onefirst, onefinal, applicable, allapplications, apply, generate, create , StepInfo, tStepInfo, exampleDerivations, recognizeRule ) where @@ -22,10 +22,11 @@ import Data.Maybe import Ideas.Common.Library hiding (applicable, apply, ready) import Ideas.Common.Traversal.Navigator (downs, navigateTo) -import Ideas.Common.Utils (fst3) import Ideas.Service.State import Ideas.Service.Types +import Ideas.Utils.Prelude (fst3) import Test.QuickCheck.Random +import qualified Data.Set as S import qualified Ideas.Common.Classes as Apply import qualified Ideas.Common.Library as Library @@ -36,9 +37,9 @@ Nothing -> Left "No random term" 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 +create rng ex txt userId = + case parser ex txt of + Left err -> Left err Right a | evalPredicate (Library.ready ex) a -> Left "Is ready" | evalPredicate (Library.suitable ex) a -> Right $ startState rng ex userId a @@ -101,6 +102,9 @@ Right (hd:_) -> Right hd Left msg -> Left msg +onefinal :: State a -> Either String (Context a) +onefinal = fmap lastTerm . solution Nothing + applicable :: Location -> State a -> [Rule (Context a)] applicable loc state = let p r = not (isBuggy r) && Apply.applicable r (setLocation loc (stateContext state)) @@ -145,8 +149,35 @@ ca = setLocation loc (stateContext state) applyOff = -- scenario 2: off-strategy case transApplyWith env (transformation r) ca of - (new, _):_ -> Right (state {stateContext = new, statePrefix = noPrefix}) - [] -> Left ("Cannot apply " ++ show r) + (new, _):_ -> Right (restart (state {stateContext = new, statePrefix = noPrefix})) + [] -> + -- first check the environment (exercise-specific property) + case environmentCheck of + Just msg -> + Left msg + Nothing -> + -- try to find a buggy rule + case siblingsFirst [ (br, envOut) | br <- ruleset (exercise state), isBuggy br, (_, envOut) <- transApplyWith env (transformation br) ca ] of + [] -> Left ("Cannot apply " ++ show r) + brs -> Left ("Buggy rule " ++ intercalate "+" (map pp brs)) + where + pp (br, envOut) + | noBindings envOut = show br + | otherwise = show br ++ " {" ++ show envOut ++ "}" + + siblingsFirst xs = ys ++ zs + where + (ys, zs) = partition (siblingInCommon r . fst) xs + + environmentCheck :: Maybe String + environmentCheck = do + p <- getProperty "environment-check" (exercise state) + p env + +siblingInCommon :: Rule a -> Rule a -> Bool +siblingInCommon r1 r2 = not (S.null (getSiblings r1 `S.intersection` getSiblings r2)) + where + getSiblings r = S.fromList (getId r : ruleSiblings r) stepsremaining :: State a -> Either String Int stepsremaining = mapSecond derivationLength . solution Nothing 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 @@ -15,6 +15,7 @@ module Ideas.Service.Diagnose ( Diagnosis(..), tDiagnosis, diagnose + , getState, getStateAndReady , difference, differenceEqual ) where @@ -58,19 +59,23 @@ f s xs | null xs = s | otherwise = s ++ "(" ++ intercalate "," xs ++ ")" -{- -newState :: Diagnosis a -> Maybe (State a) -newState diagnosis = - case diagnosis of + +getState :: Diagnosis a -> Maybe (State a) +getState = fmap fst . getStateAndReady + +getStateAndReady :: Diagnosis a -> Maybe (State a, Bool) +getStateAndReady d = + case d of + SyntaxError _ -> Nothing Buggy _ _ -> Nothing NotEquivalent _ -> Nothing - Similar _ s -> Just s - WrongRule _ s _ -> Just s - Expected _ s _ -> Just s - Detour _ s _ _ -> Just s - Correct _ s -> Just s - Unknown _ s -> Just s --} + Similar b s -> Just (s, b) + WrongRule b s _ -> Just (s, b) + Expected b s _ -> Just (s, b) + Detour b s _ _ -> Just (s, b) + Correct b s -> Just (s, b) + Unknown b s -> Just (s, b) + ---------------------------------------------------------------- -- The diagnose service 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 @@ -14,7 +14,7 @@ ( DomainReasoner(..), tDomainReasoner, newDomainReasoner , exercisesSorted, servicesSorted , findExercise, findService - , defaultScript -- , readScript + , defaultScript ) where import Data.List @@ -22,11 +22,9 @@ import Data.Monoid import Data.Ord import Ideas.Common.Library -import Ideas.Common.Utils -import Ideas.Common.Utils.TestSuite import Ideas.Service.FeedbackScript.Parser import Ideas.Service.Types -import qualified Ideas.Main.Options as Options +import Ideas.Utils.TestSuite ----------------------------------------------------------------------- -- Domain Reasoner data type @@ -75,11 +73,7 @@ ) newDomainReasoner :: IsId a => a -> DomainReasoner -newDomainReasoner a = mempty - { reasonerId = newId a - , version = Options.shortVersion - , fullVersion = Options.fullVersion - } +newDomainReasoner a = mempty {reasonerId = newId a} ----------------------------------------------------------------------- -- Domain Reasoner functions 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 @@ -22,12 +22,11 @@ import Data.Either import Data.List import Ideas.Common.Library -import Ideas.Common.Utils (Some(..)) -import Ideas.Common.Utils.Uniplate import Ideas.Service.DomainReasoner import Ideas.Service.FeedbackScript.Parser import Ideas.Service.FeedbackScript.Run import Ideas.Service.FeedbackScript.Syntax +import Ideas.Utils.Uniplate makeScriptFor :: IsId a => DomainReasoner -> a -> IO () makeScriptFor dr exId = do 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 @@ -23,7 +23,7 @@ import Data.Monoid import Ideas.Common.Id import Ideas.Service.FeedbackScript.Syntax -import Ideas.Text.Parsing +import Ideas.Utils.Parsing 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 @@ -20,7 +20,6 @@ , eval ) where -import Control.Monad import Data.List import Data.Maybe import Ideas.Common.Library hiding (ready, Environment) @@ -53,8 +52,8 @@ , recognized = Nothing , diffPair = Nothing , before = f st - , after = liftM snd next >>= f - , afterText = liftM snd next >>= g + , after = fmap snd next >>= f + , afterText = fmap snd next >>= g } where f s = fmap (`build` stateTerm s) (hasTermView (exercise s)) @@ -72,7 +71,7 @@ eval env script = either (return . findIdRef) evalText where evalText :: Text -> Maybe Text - evalText = liftM mconcat . mapM unref . textItems + evalText = fmap mconcat . mapM unref . textItems where unref (TextRef a) | a == expectedId = fmap (findIdRef . getId) (expected env) @@ -126,12 +125,12 @@ case diagnosis of SyntaxError s -> const (makeText s) Buggy _ r -> makeWrong "buggy" env {recognized = Just r} - NotEquivalent s -> makeNotEq s "noteq" env + NotEquivalent s -> makeNotEq s "noteq" env Expected _ _ r -> makeOk "ok" env {recognized = Just r} WrongRule _ _ mr -> makeWrong "wrongrule" env {recognized = mr} Similar _ _ -> makeOk "same" env Detour _ _ _ r -> makeOk "detour" env {recognized = Just r} - Correct _ _ -> makeOk "unknown" env + Correct _ _ -> makeOk "correct" env Unknown _ _ -> makeOk "unknown" env where makeOk = makeDefault "Well done!" @@ -161,7 +160,7 @@ feedbackIds :: [Id] feedbackIds = map newId - ["same", "noteq", "unknown", "ok", "buggy", "detour", "wrongrule", "hint", "step", "label"] + ["same", "noteq", "correct", "unknown", "ok", "buggy", "detour", "wrongrule", "hint", "step", "label"] attributeIds :: [Id] attributeIds = 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 @@ -22,7 +22,7 @@ import Data.List import Data.Maybe import Ideas.Common.Library -import Ideas.Common.Utils.Uniplate +import Ideas.Utils.Uniplate newtype Script = S { scriptDecls :: [Decl] } 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 @@ -65,8 +65,8 @@ -- indicates whether the student is allowed to continue (True), or forced -- to go back to the previous state (False) submittext :: Script -> State a -> String -> (Message, State a) -submittext script old input = - case parser ex input of +submittext script old txt = + case parser ex txt of Left msg -> (M (Just False) (TextString msg), old) Right a -> feedbacktext script old (inContext ex a) Nothing where @@ -86,8 +86,8 @@ Unknown _ s -> (msg False, s) where diagnosis = diagnose old new motivationId - output = feedbackDiagnosis diagnosis env script - msg b = M (Just b) output + out = feedbackDiagnosis diagnosis env script + msg b = M (Just b) out ex = exercise old motivationRule = motivationId >>= getRule ex env = (newEnvironment old motivationRule) 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 @@ -18,9 +18,9 @@ import Data.Maybe import Ideas.Common.Library import Ideas.Common.Strategy.Symbol -import Ideas.Common.Utils (fst3) import Ideas.Service.State import Ideas.Service.Types +import Ideas.Utils.Prelude (fst3) problemDecomposition :: Maybe Id -> State a -> Maybe (Answer a) -> Either String (Reply a) problemDecomposition msloc state maybeAnswer diff --git a/src/Ideas/Service/Request.hs b/src/Ideas/Service/Request.hs deleted file mode 100644 --- a/src/Ideas/Service/Request.hs +++ /dev/null @@ -1,115 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- ------------------------------------------------------------------------------ - -module Ideas.Service.Request where - -import Data.Char -import Data.List -import Data.Maybe -import Ideas.Common.Library hiding (exerciseId) -import Ideas.Common.Utils - -data Request = Request - { serviceId :: Maybe Id - , exerciseId :: Maybe Id - , source :: Maybe String - , feedbackScript :: Maybe String - , 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 Nothing XML [] - -data Schema = V1 | V2 | NoLogging deriving (Show, Eq) - -getSchema :: Request -> Schema -getSchema = fromMaybe V1 . logSchema -- log schema V1 is the default - -readSchema :: Monad m => String -> m Schema -readSchema s0 - | s == "v1" = return V1 - | s == "v2" = return V2 - | s `elem` ["false", "no"] = return NoLogging - | otherwise = fail "Unknown schema" - where - s = map toLower (filter isAlphaNum s0) - -data DataFormat = XML | JSON - deriving Show -- needed for LoggingDatabase - -data Encoding = EncHTML -- html page as output - | EncOpenMath -- encode terms in OpenMath - | EncString -- encode terms as strings - | EncCompact -- compact ouput - | EncPretty -- pretty output - | EncJSON -- encode terms in JSON - deriving Eq - -instance Show Encoding where - showList xs rest = intercalate "+" (map show xs) ++ rest - show EncHTML = "html" - show EncOpenMath = "openmath" - show EncString = "string" - show EncCompact = "compact" - show EncPretty = "pretty" - show EncJSON = "json" - -htmlOutput :: Request -> Bool -htmlOutput = (EncHTML `elem`) . encoding - -compactOutput :: Request -> Bool -compactOutput req = - case (EncCompact `elem` xs, EncPretty `elem` xs) of - (True, False) -> True - (False, True) -> False - _ -> isJust (cgiBinary req) - where - xs = encoding req - -useOpenMath :: Request -> Bool -useOpenMath 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 - -discoverDataFormat :: Monad m => String -> m DataFormat -discoverDataFormat xs = - case dropWhile isSpace xs of - '<':_ -> return XML - '{':_ -> return JSON - _ -> fail "Unknown data format" - -readEncoding :: Monad m => String -> m [Encoding] -readEncoding = mapM (f . map toLower) . splitsWithElem '+' - where - f "html" = return EncHTML - f "openmath" = return EncOpenMath - 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 @@ -14,13 +14,13 @@ import Ideas.Common.ExerciseTests import Ideas.Common.Library hiding (apply, applicable, suitable, ready) -import Ideas.Common.Utils.TestSuite hiding (Message) import Ideas.Service.BasicServices import Ideas.Service.DomainReasoner import Ideas.Service.FeedbackText import Ideas.Service.ProblemDecomposition (problemDecomposition) import Ideas.Service.State import Ideas.Service.Types +import Ideas.Utils.TestSuite hiding (Message) import qualified Ideas.Service.Diagnose as Diagnose import qualified Ideas.Service.ProblemDecomposition as ProblemDecomposition import qualified Ideas.Service.Submit as Submit @@ -31,7 +31,7 @@ serviceList :: [Service] serviceList = -- basic services - [ solutionS, derivationS, allfirstsS, onefirstS + [ solutionS, derivationS, allfirstsS, onefirstS, onefinalS , equivalenceS, similarityS, suitableS, finishedS, readyS , stepsremainingS, allapplicationsS , applyS, generateS, createS, applicableS @@ -81,6 +81,11 @@ \this rule are returned." $ onefirst ::: tState .-> tString :|: Tag "elem" (tPair tStepInfo tState) -- special tag for (legacy) xml encoding + +onefinalS :: Service +onefinalS = makeService "basic.onefinal" + "Returns a final term, after taking zero or more steps, by applying the strategy." $ + onefinal ::: tState .-> tError tContext equivalenceS :: Service equivalenceS = makeService "basic.equivalence" 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 @@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- module Ideas.Service.Submit - ( submit, Result(..), tResult + ( submit, Result(..), tResult, getState ) where import Data.Maybe @@ -30,6 +30,15 @@ | Ok [Rule (Context a)] (State a) -- equivalent | Detour [Rule (Context a)] (State a) -- equivalent | Unknown (State a) -- equivalent + +getState :: Result a -> Maybe (State a) +getState r = + case r of + Buggy _ -> Nothing + NotEquivalent _ -> Nothing + Ok _ s -> Just s + Detour _ s -> Just s + Unknown s -> Just s fromDiagnose :: Diagnosis a -> Result a fromDiagnose diagnosis = 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 @@ -34,11 +34,10 @@ import Data.Maybe import Data.Tree import Ideas.Common.Library -import Ideas.Common.Utils import Ideas.Service.FeedbackScript.Syntax import Ideas.Service.State import Test.QuickCheck.Random (QCGen) -import qualified Ideas.Common.Utils.TestSuite as TestSuite +import qualified Ideas.Utils.TestSuite as TestSuite ----------------------------------------------------------------------------- -- Services 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 @@ -59,7 +59,7 @@ | css <- styleSheets page ] , mconcat - [ tag "script" ("src" .=. js) + [ element "script" ["src" .=. js, "type" .=. "text/javascript", string " "] | js <- scripts page ] ] 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 @@ -26,7 +26,7 @@ import Control.Monad import Data.List (intersperse) import Data.Maybe -import Ideas.Text.Parsing hiding (string, char) +import Ideas.Utils.Parsing hiding (string, char) import System.IO.Error import Test.QuickCheck import Text.PrettyPrint.Leijen hiding ((<$>)) @@ -107,7 +107,7 @@ instance InJSON Int where toJSON = toJSON . toInteger - fromJSON = liftM fromInteger . fromJSON + fromJSON = fmap fromInteger . fromJSON instance InJSON Integer where toJSON = Number . I @@ -138,17 +138,17 @@ instance (InJSON a, InJSON b) => InJSON (a, b) where toJSON (a, b) = Array [toJSON a, toJSON b] - fromJSON (Array [a, b]) = liftM2 (,) (fromJSON a) (fromJSON b) + fromJSON (Array [a, b]) = (,) <$> fromJSON a <*> fromJSON b fromJSON _ = fail "expecting an array with 2 elements" instance (InJSON a, InJSON b, InJSON c) => InJSON (a, b, c) where toJSON (a, b, c) = Array [toJSON a, toJSON b, toJSON c] - fromJSON (Array [a, b, c]) = liftM3 (,,) (fromJSON a) (fromJSON b) (fromJSON c) + fromJSON (Array [a, b, c]) = (,,) <$> fromJSON a <*> fromJSON b <*> fromJSON c fromJSON _ = fail "expecting an array with 3 elements" instance (InJSON a, InJSON b, InJSON c, InJSON d) => InJSON (a, b, c, d) where toJSON (a, b, c, d) = Array [toJSON a, toJSON b, toJSON c, toJSON d] - fromJSON (Array [a, b, c, d]) = liftM4 (,,,) (fromJSON a) (fromJSON b) (fromJSON c) (fromJSON d) + fromJSON (Array [a, b, c, d]) = (,,,) <$> fromJSON a <*> fromJSON b <*> fromJSON c <*> fromJSON d fromJSON _ = fail "expecting an array with 4 elements" instance InJSON IOException where @@ -270,13 +270,13 @@ arbitrary = sized arbJSON instance Arbitrary Number where - arbitrary = oneof [liftM I arbitrary, liftM (D . fromInteger) arbitrary] + arbitrary = oneof [I <$> arbitrary, (D . fromInteger) <$> arbitrary] arbJSON :: Int -> Gen JSON arbJSON n | n == 0 = oneof - [ liftM Number arbitrary, liftM String myStringGen - , liftM Boolean arbitrary, return Null + [ Number <$> arbitrary, String <$> myStringGen + , Boolean <$> arbitrary, return Null ] | otherwise = oneof [ arbJSON 0 diff --git a/src/Ideas/Text/Latex.hs b/src/Ideas/Text/Latex.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Text/Latex.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Support for LaTeX. +-- +----------------------------------------------------------------------------- + +module Ideas.Text.Latex + ( Latex, ToLatex(..), (<>) + , array, commas, brackets, parens + , command + ) where + +import Data.List +import Data.Monoid +import Data.String + +newtype Latex = L { showLatex :: String } + +instance Show Latex where + show = showLatex + +instance IsString Latex where + fromString = L + +instance Monoid Latex where + mempty = L [] + L xs `mappend` L ys = L (mappend xs ys) + +class ToLatex a where + toLatex :: a -> Latex + toLatexPrec :: Int -> a -> Latex + toLatexList :: [a] -> Latex + -- default implementations + toLatex = toLatexPrec 0 + toLatexPrec = const toLatex + toLatexList = brackets . commas . map toLatex + {-# MINIMAL toLatex | toLatexPrec #-} + +instance ToLatex a => ToLatex [a] where + toLatex = toLatexList + toLatexPrec = const toLatexList + +instance ToLatex a => ToLatex (Maybe a) where + toLatexPrec = maybe mempty . toLatexPrec + +instance ToLatex Char where + toLatex = fromString . return + toLatexList = fromString + +instance ToLatex Int where + toLatex = fromString . show + +commas :: [Latex] -> Latex +commas = mconcat . intersperse ",\\:" + +brackets, parens :: Latex -> Latex +brackets s = "[" <> s <> "]" +parens s = "(" <> s <> ")" + +array :: String -> [[Latex]] -> Latex +array s rows = "\\begin{array}{" <> fromString s <> "}" + <> mconcat (intersperse "\\\\" (map (mconcat . intersperse " & ") rows)) + <> "\\end{array}" + +command :: String -> Latex +command s = toLatex ("\\" ++ s ++ " ") 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,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- Copyright 2016, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files @@ -19,7 +18,6 @@ import Data.Generics.Uniplate.Direct hiding (children) import Data.List (nub) import Data.Maybe -import Data.Typeable import Ideas.Text.OpenMath.Symbol import Ideas.Text.XML @@ -30,7 +28,7 @@ | OMS Symbol | OMA [OMOBJ] | OMBIND OMOBJ [String] OMOBJ - deriving (Show, Eq, Typeable) + deriving (Show, Eq) instance InXML OMOBJ where toXML = omobj2xml @@ -63,7 +61,9 @@ return (OMA ys) [] | name xml == "OMS" -> do - let mcd = findAttribute "cd" xml + let mcd = case findAttribute "cd" xml of + Just "unknown" -> Nothing + this -> this n <- findAttribute "name" xml return (OMS (mcd, n)) 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 @@ -34,15 +34,15 @@ relation1List ++ transc1List rec 0 = frequency - [ (1, liftM OMI arbitrary) - , (1, liftM (\n -> OMF (fromInteger n / 1000)) arbitrary) - , (1, liftM OMV arbitrary) + [ (1, OMI <$> arbitrary) + , (1, (\n -> OMF (fromInteger n / 1000)) <$> arbitrary) + , (1, OMV <$> arbitrary) , (5, elements $ map OMS symbols) ] rec n = frequency [ (1, rec 0) - , (3, choose (1,4) >>= liftM OMA . (`replicateM` f)) - , (1, liftM3 OMBIND f arbitrary f) + , (3, choose (1,4) >>= fmap OMA . (`replicateM` f)) + , (1, OMBIND <$> f <*> arbitrary <*> f) ] where f = rec (n `div` 2) diff --git a/src/Ideas/Text/Parsing.hs b/src/Ideas/Text/Parsing.hs deleted file mode 100644 --- a/src/Ideas/Text/Parsing.hs +++ /dev/null @@ -1,120 +0,0 @@ ------------------------------------------------------------------------------ --- 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. ------------------------------------------------------------------------------ --- | --- Maintainer : bastiaan.heeren@ou.nl --- Stability : provisional --- Portability : portable (depends on ghc) --- --- Utility functions for parsing with Parsec library --- ------------------------------------------------------------------------------ - -module Ideas.Text.Parsing - ( module Export - , (<*>), (*>), (<*), (<$>), (<$), (<**>) - , parseSimple, complete, skip, (<..>), ranges, stopOn - , naturalOrFloat, float - , UnbalancedError(..), balanced - ) where - -import Control.Applicative hiding ((<|>)) -import Control.Arrow -import Control.Monad -import Data.Char -import Data.List -import Text.ParserCombinators.Parsec as Export -import Text.ParserCombinators.Parsec.Expr as Export -import Text.ParserCombinators.Parsec.Language as Export -import Text.ParserCombinators.Parsec.Pos - -parseSimple :: Parser a -> String -> Either String a -parseSimple p = left show . runParser (complete p) () "" - -complete :: Parser a -> Parser a -complete p = spaces *> (p <* eof) - -skip :: Parser a -> Parser () -skip = void - --- Like the combinator from parser, except that for doubles --- the read instance is used. This is a more precies representation --- of the double (e.g., 1.413 is not 1.413000000001). -naturalOrFloat :: Parser (Either Integer Double) -naturalOrFloat = do - a <- num - b <- option "" ((:) <$> char '.' <*> nat) - c <- option "" ((:) <$> oneOf "eE" <*> num) - spaces - case reads (a++b++c) of - _ | null b && null c -> - case a of - '-':xs -> return (Left (negate (readInt xs))) - xs -> return (Left (readInt xs)) - [(d, [])] -> return (Right d) - _ -> fail "not a float" - where - nat = many1 digit - num = maybe id (:) <$> optionMaybe (char '-') <*> nat - readInt = foldl' op 0 -- ' - op a b = a*10+fromIntegral (ord b)-48 - -float :: Parser Double -float = do - a <- nat - b <- option "" ((:) <$> char '.' <*> nat) - c <- option "" ((:) <$> oneOf "eE" <*> num) - case reads (a++b++c) of - [(d, [])] -> return d - _ -> fail "not a float" - where - nat = many1 digit - num = (:) <$> char '-' <*> nat - -infix 6 <..> - -(<..>) :: Char -> Char -> Parser Char -x <..> y = satisfy (\c -> c >= x && c <= y) - -ranges :: [(Char, Char)] -> Parser Char -ranges xs = choice [ a <..> b | (a, b) <- xs ] - --- return in local function f needed for backwards compatibility -stopOn :: [String] -> Parser String -stopOn ys = rec - where - stop = choice (map f ys) - f x = try (string x >> return ' ') - rec = (:) <$ notFollowedBy stop <*> anyChar <*> rec - <|> return [] - --- simple function for finding unbalanced pairs (e.g. parentheses) -balanced :: [(Char, Char)] -> String -> Maybe UnbalancedError -balanced table = run (initialPos "") [] - where - run _ [] [] = Nothing - run _ ((pos, c):_) [] = return (NotClosed pos c) - run pos stack (x:xs) - | x `elem` opens = - run next ((pos, x):stack) xs - | x `elem` closes = - case stack of - (_, y):rest | Just x == lookup y table -> run next rest xs - _ -> return (NotOpened pos x) - | otherwise = - run next stack xs - where - next = updatePosChar pos x - - (opens, closes) = unzip table - -data UnbalancedError = NotClosed SourcePos Char - | NotOpened SourcePos Char - -instance Show UnbalancedError where - show (NotClosed pos c) = - show pos ++ ": Opening symbol " ++ [c] ++ " is not closed" - show (NotOpened pos c) = - show pos ++ ": Closing symbol " ++ [c] ++ " has no matching symbol" 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 @@ -35,11 +35,11 @@ -- | Encode a string to UTF8 format (monadic) encodeM :: Monad m => String -> m String -encodeM = liftM (map chr . concat) . mapM (toUTF8 . ord) +encodeM = fmap (map chr . concat) . mapM (toUTF8 . ord) -- | Decode an UTF8 format string to unicode points (monadic) decodeM :: Monad m => String -> m String -decodeM = liftM (map chr) . fromUTF8 . map ord +decodeM = fmap (map chr) . fromUTF8 . map ord -- | Test whether the argument is a proper UTF8 string isUTF8 :: String -> Bool @@ -110,7 +110,7 @@ propEncoding = forAll (sized gen) valid where gen n = replicateM n someChar - someChar = liftM chr $ oneof + someChar = chr <$> oneof -- To get a nice distribution over the number of bytes used -- in the encoding [ choose (0, 127), choose (128, 2047) 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 @@ -134,9 +134,12 @@ escape :: String -> String escape = concatMap f where - f '<' = "<" - f '>' = ">" - f '&' = "&" + f '<' = "<" + f '>' = ">" + f '&' = "&" + f '"' = """ + f '\'' = "'" + f '\n' = " " f c = [c] trim :: String -> String 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 @@ -32,7 +32,7 @@ data Reference = CharRef Int | EntityRef String -data Parameter = Parameter String +newtype Parameter = Parameter String data XMLDoc = XMLDoc { versionInfo :: Maybe String 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 @@ -21,10 +21,10 @@ import Control.Arrow import Data.Char (chr, ord) import Data.Maybe -import Ideas.Text.Parsing (parseSimple) import Ideas.Text.XML.Document (Name, prettyElement) import Ideas.Text.XML.Parser (document) import Ideas.Text.XML.Unicode (decoding) +import Ideas.Utils.Parsing (parseSimple) import qualified Ideas.Text.XML.Document as D data Element = Element 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 @@ -21,9 +21,9 @@ import Data.Char (toUpper, ord, isSpace) import Data.List (foldl') -- ' import Data.Maybe (catMaybes) -import Ideas.Text.Parsing hiding (digit, letter, space) import Ideas.Text.XML.Document hiding (versionInfo, name, content) import Ideas.Text.XML.Unicode +import Ideas.Utils.Parsing hiding (digit, letter, space) import Prelude hiding (seq) import qualified Ideas.Text.XML.Document as D diff --git a/src/Ideas/Utils/BlackBoxTests.hs b/src/Ideas/Utils/BlackBoxTests.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Utils/BlackBoxTests.hs @@ -0,0 +1,110 @@ +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- + +module Ideas.Utils.BlackBoxTests (blackBoxTests, TestRunner) where + +import Control.Monad +import Data.Char +import Data.List +import Ideas.Utils.TestSuite +import System.Directory +import System.IO +import qualified Data.Algorithm.Diff as Diff + +type TestRunner = String -> IO String + +-- Returns the number of tests performed +blackBoxTests :: TestRunner -> [String] -> String -> IO TestSuite +blackBoxTests runner exts = rec + where + rec path = do + -- analyse content + xs0 <- getDirectoryContents path + let (files, xs1) = partition (`elemExts` exts) xs0 + xs2 = map (path ) (filter ((/= ".") . take 1) xs1) + -- recursively visit subdirectories + subs <- filterM doesDirectoryExist xs2 + rest <- mapM rec subs + return $ suite ("Directory " ++ simplerDirectory path) $ + [ doBlackBoxTest runner (path x) + | x <- files + ] ++ rest + +doBlackBoxTest :: TestRunner -> FilePath -> TestSuite +doBlackBoxTest runner path = + assertMessageIO (stripDirectoryPart path) $ + -- Comparing output with expected output + withFile path ReadMode $ \h1 -> do + hSetBinaryMode h1 True + txt <- hGetContents h1 + out <- runner txt + withFile expPath ReadMode $ \h2 -> do + hSetBinaryMode h2 True + expt <- hGetContents h2 + -- Force evaluation of the result, to make sure that + -- all file handles are closed afterwards. + let list1 = prepare expt + list2 = prepare out + msg = unlines (path : diffs list1 list2) + if list1 == list2 then return mempty else do + force msg -- force evaluation of message before closing files + return (message msg) + where + expPath = baseOf path ++ ".exp" + baseOf = reverse . drop 1 . dropWhile (/= '.') . reverse + +elemExts :: FilePath -> [String] -> Bool +elemExts s = any (\xs -> ('.':xs) `isSuffixOf` s) + +force :: String -> IO () +force s | sum (map ord s) >= 0 = return () + | otherwise = error "force" + +prepare :: String -> [String] +prepare = filter (not . null) . lines . filter (/= '\r') . noVersion + where + noVersion s | "version\": \"" `isPrefixOf` s = + "version\": \"X" ++ dropWhile (/='"') (drop 11 s) + noVersion s | "version=\"" `isPrefixOf` s = + "version=\"X" ++ dropWhile (/='"') (drop 9 s) + noVersion (x:xs) = x:noVersion xs + noVersion [] = [] + +diffs :: [String] -> [String] -> [String] +diffs xs ys = concatMap f $ Diff.getDiff xs ys + where + f (Diff.First a) = ["- " ++ a] + f (Diff.Second a) = ["+ " ++ a] + f _ = [] + +simplerDirectory :: String -> String +simplerDirectory s + | "../" `isPrefixOf` s = simplerDirectory (drop 3 s) + | "test/" `isPrefixOf` s = simplerDirectory (drop 5 s) + | otherwise = s + +stripDirectoryPart :: String -> String +stripDirectoryPart = reverse . takeWhile (/= '/') . reverse + +() :: FilePath -> FilePath -> FilePath +x y = x ++ "/" ++ y + +{- +logicConfluence :: IO () +logicConfluence = reportTest "logic rules" (isConfluent f rs) + where + f = normalizeWith ops . normalFormWith ops rs + ops = map makeCommutative Logic.logicOperators + rwrs = Logic.logicRules \\ [Logic.ruleOrOverAnd, Logic.ruleCommOr, Logic.ruleCommAnd] + rs = [ r | RewriteRule r <- concatMap transformations rwrs ] + -- eqs = bothWays [ r | RewriteRule r <- concatMap transformations Logic.logicRules ] +-} diff --git a/src/Ideas/Utils/Parsing.hs b/src/Ideas/Utils/Parsing.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Utils/Parsing.hs @@ -0,0 +1,120 @@ +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Utility functions for parsing with Parsec library +-- +----------------------------------------------------------------------------- + +module Ideas.Utils.Parsing + ( module Export + , (<*>), (*>), (<*), (<$>), (<$), (<**>) + , parseSimple, complete, skip, (<..>), ranges, stopOn + , naturalOrFloat, float + , UnbalancedError(..), balanced + ) where + +import Control.Applicative hiding ((<|>)) +import Control.Arrow +import Control.Monad +import Data.Char +import Data.List +import Text.ParserCombinators.Parsec as Export +import Text.ParserCombinators.Parsec.Expr as Export +import Text.ParserCombinators.Parsec.Language as Export +import Text.ParserCombinators.Parsec.Pos + +parseSimple :: Parser a -> String -> Either String a +parseSimple p = left show . runParser (complete p) () "" + +complete :: Parser a -> Parser a +complete p = spaces *> (p <* eof) + +skip :: Parser a -> Parser () +skip = void + +-- Like the combinator from parser, except that for doubles +-- the read instance is used. This is a more precies representation +-- of the double (e.g., 1.413 is not 1.413000000001). +naturalOrFloat :: Parser (Either Integer Double) +naturalOrFloat = do + a <- num + b <- option "" ((:) <$> char '.' <*> nat) + c <- option "" ((:) <$> oneOf "eE" <*> num) + spaces + case reads (a++b++c) of + _ | null b && null c -> + case a of + '-':xs -> return (Left (negate (readInt xs))) + xs -> return (Left (readInt xs)) + [(d, [])] -> return (Right d) + _ -> fail "not a float" + where + nat = many1 digit + num = maybe id (:) <$> optionMaybe (char '-') <*> nat + readInt = foldl' op 0 -- ' + op a b = a*10+fromIntegral (ord b)-48 + +float :: Parser Double +float = do + a <- nat + b <- option "" ((:) <$> char '.' <*> nat) + c <- option "" ((:) <$> oneOf "eE" <*> num) + case reads (a++b++c) of + [(d, [])] -> return d + _ -> fail "not a float" + where + nat = many1 digit + num = (:) <$> char '-' <*> nat + +infix 6 <..> + +(<..>) :: Char -> Char -> Parser Char +x <..> y = satisfy (\c -> c >= x && c <= y) + +ranges :: [(Char, Char)] -> Parser Char +ranges xs = choice [ a <..> b | (a, b) <- xs ] + +-- return in local function f needed for backwards compatibility +stopOn :: [String] -> Parser String +stopOn ys = rec + where + stop = choice (map f ys) + f x = try (string x >> return ' ') + rec = (:) <$ notFollowedBy stop <*> anyChar <*> rec + <|> return [] + +-- simple function for finding unbalanced pairs (e.g. parentheses) +balanced :: [(Char, Char)] -> String -> Maybe UnbalancedError +balanced table = run (initialPos "") [] + where + run _ [] [] = Nothing + run _ ((pos, c):_) [] = return (NotClosed pos c) + run pos stack (x:xs) + | x `elem` opens = + run next ((pos, x):stack) xs + | x `elem` closes = + case stack of + (_, y):rest | Just x == lookup y table -> run next rest xs + _ -> return (NotOpened pos x) + | otherwise = + run next stack xs + where + next = updatePosChar pos x + + (opens, closes) = unzip table + +data UnbalancedError = NotClosed SourcePos Char + | NotOpened SourcePos Char + +instance Show UnbalancedError where + show (NotClosed pos c) = + show pos ++ ": Opening symbol " ++ [c] ++ " is not closed" + show (NotOpened pos c) = + show pos ++ ": Closing symbol " ++ [c] ++ " has no matching symbol" diff --git a/src/Ideas/Utils/Prelude.hs b/src/Ideas/Utils/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Utils/Prelude.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A collection of general utility functions +-- +----------------------------------------------------------------------------- + +module Ideas.Utils.Prelude + ( Some(..), ShowString(..), readInt, readM + , subsets, isSubsetOf + , cartesian, distinct, allsame + , fixpoint + , splitAtElem, splitsWithElem + , timedSeconds + , fst3, snd3, thd3 + , headM, findIndexM + , elementAt, changeAt, replaceAt + , list + ) where + +import Data.Char +import Data.List +import System.Timeout + +data Some f = forall a . Some (f a) + +newtype ShowString = ShowString { fromShowString :: String } + deriving (Eq, Ord) + +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 + | any (not . isDigit) xs = Nothing + | otherwise = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' + +readM :: (Monad m, Read a) => String -> m a +readM s = case reads s of + [(a, xs)] | all isSpace xs -> return a + _ -> fail ("no read: " ++ s) + +subsets :: [a] -> [[a]] +subsets = foldr op [[]] + where op a xs = xs ++ map (a:) xs + +isSubsetOf :: Eq a => [a] -> [a] -> Bool +isSubsetOf xs ys = all (`elem` ys) xs + +cartesian :: [a] -> [b] -> [(a, b)] +cartesian as bs = [ (a, b) | a <- as, b <- bs ] + +distinct :: Eq a => [a] -> Bool +distinct [] = True +distinct (x:xs) = notElem x xs && distinct xs + +allsame :: Eq a => [a] -> Bool +allsame [] = True +allsame (x:xs) = all (==x) xs + +fixpoint :: Eq a => (a -> a) -> a -> a +fixpoint f = rec . iterate f + where + rec [] = error "Ideas.Common.Utils: empty list" + rec (x:xs) + | x == head xs = x + | otherwise = rec xs + +splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a]) +splitAtElem c s = + case break (==c) s of + (xs, _:ys) -> Just (xs, ys) + _ -> Nothing + +splitsWithElem :: Eq a => a -> [a] -> [[a]] +splitsWithElem c s = + case splitAtElem c s of + Just (xs, ys) -> xs : splitsWithElem c ys + Nothing -> [s] + +timedSeconds :: Int -> IO a -> IO a +timedSeconds n m = timeout (n * 10^(6 :: Int)) m >>= + maybe (fail ("Timeout after " ++ show n ++ " seconds")) return + +fst3 :: (a, b, c) -> a +fst3 (x, _, _) = x + +snd3 :: (a, b, c) -> b +snd3 (_, x, _) = x + +thd3 :: (a, b, c) -> c +thd3 (_, _, x) = x + +-- generalized list functions (results in monad) +headM :: Monad m => [a] -> m a +headM (a:_) = return a +headM _ = fail "headM" + +findIndexM :: Monad m => (a -> Bool) -> [a] -> m Int +findIndexM p = maybe (fail "findIndexM") return . findIndex p + +elementAt :: Monad m => Int -> [a] -> m a +elementAt i = headM . drop i + +changeAt :: Monad m => Int -> (a -> a) -> [a] -> m [a] +changeAt i f as = + case splitAt i as of + (xs, y:ys) -> return (xs ++ f y : ys) + _ -> fail "changeAt" + +replaceAt :: Monad m => Int -> a -> [a] -> m [a] +replaceAt i = changeAt i . const + +list :: b -> ([a] -> b) -> [a] -> b +list b f xs = if null xs then b else f xs diff --git a/src/Ideas/Utils/QuickCheck.hs b/src/Ideas/Utils/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Utils/QuickCheck.hs @@ -0,0 +1,102 @@ +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Extensions to the QuickCheck library +-- +----------------------------------------------------------------------------- + +module Ideas.Utils.QuickCheck + ( module Test.QuickCheck + -- * Data type + , ArbGen, generator, generators + -- * Constructors + , arbGen, constGen, constGens, unaryGen, unaryGens + , unaryArbGen, binaryGen, binaryGens, toArbGen + -- * Frequency combinators + , common, uncommon, rare, changeFrequency + ) where + +import Control.Arrow +import Control.Monad +import Data.Ratio +import Test.QuickCheck + +--------------------------------------------------------- +-- @ArbGen@ datatype + +newtype ArbGen a = AG [(Rational, (Int, Gen ([a] -> a)))] + +instance Monoid (ArbGen a) where + mempty = AG mempty + AG xs `mappend` AG ys = AG (xs `mappend` ys) + +generator :: ArbGen a -> Gen a +generator (AG pairs) = sized rec + where + factor = foldr (lcm . denominator . fst) 1 pairs + rec n = frequency (map make (select pairs)) + where + select + | n == 0 = filter ((==0) . fst . snd) + | otherwise = id + make (r, (a, gf)) = + let m = round (fromInteger factor*r) + xs = replicateM a $ rec $ n `div` 2 + in (m, gf <*> xs) + +generators :: [ArbGen a] -> Gen a +generators = generator . mconcat + +--------------------------------------------------------- +-- Constructors + +arbGen :: Arbitrary b => (b -> a) -> ArbGen a +arbGen f = newGen 0 ((const . f) <$> arbitrary) + +constGen :: a -> ArbGen a +constGen = pureGen 0 . const + +constGens :: [a] -> ArbGen a +constGens = mconcat . map constGen + +unaryGen :: (a -> a) -> ArbGen a +unaryGen f = pureGen 1 (f . head) + +unaryArbGen :: Arbitrary b => (b -> a -> a) -> ArbGen a +unaryArbGen f = newGen 1 $ (\a -> f a . head) <$> arbitrary + +unaryGens :: [a -> a] -> ArbGen a +unaryGens = mconcat . map unaryGen + +binaryGen :: (a -> a -> a) -> ArbGen a +binaryGen f = pureGen 2 (\xs -> f (head xs) (xs !! 1)) + +binaryGens :: [a -> a -> a] -> ArbGen a +binaryGens = mconcat . map binaryGen + +pureGen :: Int -> ([a] -> a) -> ArbGen a +pureGen n = newGen n . return + +toArbGen :: Gen a -> ArbGen a +toArbGen = newGen 0 . fmap const + +newGen :: Int -> Gen ([a] -> a) -> ArbGen a +newGen n f = AG [(1, (n, f))] + +--------------------------------------------------------- +-- Frequency combinators + +common, uncommon, rare :: ArbGen a -> ArbGen a +common = changeFrequency 2 +uncommon = changeFrequency (1/2) +rare = changeFrequency (1/5) + +changeFrequency :: Rational -> ArbGen a -> ArbGen a +changeFrequency r (AG xs) = AG (map (first (*r)) xs) diff --git a/src/Ideas/Utils/StringRef.hs b/src/Ideas/Utils/StringRef.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Utils/StringRef.hs @@ -0,0 +1,134 @@ +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- References to Strings, proving a fast comparison implementation (Eq and +-- Ord) that uses a hash function. Code is based on Daan Leijen's Lazy +-- Virutal Machine (LVM) identifiers. +-- +----------------------------------------------------------------------------- + +module Ideas.Utils.StringRef + ( StringRef, stringRef, toString, tableStatus + ) where + +import Data.Bits +import Data.IORef +import Data.List +import System.IO.Unsafe +import qualified Data.IntMap as IM + +---------------------------------------------------------------- +-- StringRef datatype and instance declarations + +data StringRef = S !Int + deriving (Eq, Ord) + +---------------------------------------------------------------- +-- Hash table + +type HashTable = IM.IntMap [String] + +{-# NOINLINE tableRef #-} +tableRef :: IORef HashTable +tableRef = unsafePerformIO (newIORef IM.empty) + +---------------------------------------------------------------- +-- Conversion to and from strings + +stringRef :: String -> StringRef +stringRef s = unsafePerformIO $ do + let hash = hashString s + m <- readIORef tableRef + case IM.insertLookupWithKey (const combine) hash [s] m of + (Nothing, new) -> do + writeIORef tableRef new + return (S (encodeIndexZero hash)) + (Just old, new) -> + case elemIndex s old of + Just index -> + return (S (encode hash index)) + Nothing -> do + let index = length old + writeIORef tableRef new + return (S (encode hash index)) + +toString :: StringRef -> String +toString (S i) = unsafePerformIO $ do + m <- readIORef tableRef + case IM.lookup (extractHash i) m of + Just xs -> return (atIndex (extractIndex i) xs) + Nothing -> intErr "id not found" + +---------------------------------------------------------------- +-- Bit encoding + +encode :: Int -> Int -> Int +encode hash index = hash + index `shiftL` 12 + +encodeIndexZero :: Int -> Int +encodeIndexZero hash = hash + +extractHash :: Int -> Int +extractHash i = i `mod` 4096 + +extractIndex :: Int -> Int +extractIndex i = i `shiftR` 12 + +---------------------------------------------------------------- +-- Hash function + +-- simple hash function that performs quite good in practice +hashString :: String -> Int +hashString s = (f s `mod` prime) `mod` maxHash + where + f = foldl' next 0 -- ' strict fold + next n c = n*65599 + fromEnum c + prime = 32537 --65599 -- require: prime < maxHash + +maxHash :: Int +maxHash = 0xFFF -- 12 bits + +---------------------------------------------------------------- +-- Utility functions + +atIndex :: Int -> [a] -> a +atIndex 0 (x:_) = x +atIndex i (_:xs) = atIndex (i-1) xs +atIndex _ _ = intErr "corrupt symbol table" + +combine :: Eq a => [a] -> [a] -> [a] +combine [a] = rec + where + rec [] = [a] + rec this@(x:xs) + | a == x = this + | otherwise = x:rec xs +combine _ = intErr "combine" + +intErr :: String -> a +intErr s = error ("Internal error in Ideas.Common.StringRef: " ++ s) + +---------------------------------------------------------------- +-- Testing and debugging + +tableStatus :: IO String +tableStatus = readIORef tableRef >>= \m -> + let xs = map f (IM.assocs m) + f (i, ys) = '#' : show i ++ ": " ++ intercalate ", " (map g (frequency ys)) ++ + " [total = " ++ show (length ys) ++ "]" + g (a, n) | n == 1 = show a + | otherwise = show a ++ " (" ++ show n ++ ")" + in return $ unlines xs + +frequency :: Eq a => [a] -> [(a, Int)] +frequency [] = [] +frequency (x:xs) = + let (ys, zs) = partition (==x) xs + in (x, 1+length ys) : frequency zs diff --git a/src/Ideas/Utils/TestSuite.hs b/src/Ideas/Utils/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Utils/TestSuite.hs @@ -0,0 +1,420 @@ +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A lightweight wrapper for organizing tests (including QuickCheck tests). It +-- introduces the notion of a test suite, and it stores the test results for +-- later inspection (e.g., for the generation of a test report). A TestSuite +-- is a monoid. +-- +----------------------------------------------------------------------------- + +module Ideas.Utils.TestSuite + ( -- * TestSuite + TestSuite, module Data.Monoid + , suite, useProperty, usePropertyWith + , assertTrue, assertNull, assertEquals, assertIO + , assertMessage, assertMessageIO + , onlyWarnings, rateOnError + -- * Running a test suite + , runTestSuite, runTestSuiteResult + -- * Test Suite Result + , Result, subResults, findSubResult + , justOneSuite, allMessages, topMessages + , nrOfTests, nrOfErrors, nrOfWarnings + , timeInterval, makeSummary, printSummary + -- * Message + , Message, message, warning, messageLines + -- * Status + , Status, HasStatus(..) + , isError, isWarning, isOk + -- * Rating + , Rating, HasRating(..) + ) where + +import Control.Exception +import Control.Monad +import Data.Foldable (toList) +import Data.IORef +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Time +import System.IO +import Test.QuickCheck hiding (Result) +import qualified Data.Sequence as S + +---------------------------------------------------------------- +-- Test Suite + +newtype TestSuite = TS (S.Seq Test) + +data Test = Case String (IO Message) + | Suite String TestSuite + +instance Monoid TestSuite where + mempty = TS mempty + TS xs `mappend` TS ys = TS (xs <> ys) + +tests :: TestSuite -> [Test] +tests (TS xs) = toList xs + +makeTestSuite :: Test -> TestSuite +makeTestSuite = TS . S.singleton + +---------------------------------------------------------------- +-- Test suite constructors + +-- | Construct a (named) test suite containing test cases and other suites +suite :: String -> [TestSuite] -> TestSuite +suite s = makeTestSuite . Suite s . mconcat + +-- | Turn a QuickCheck property into the test suite. The first argument is +-- a label for the property +useProperty :: Testable prop => String -> prop -> TestSuite +useProperty = flip usePropertyWith stdArgs + +-- | Turn a QuickCheck property into the test suite, also providing a test +-- configuration (Args) +usePropertyWith :: Testable prop => String -> Args -> prop -> TestSuite +usePropertyWith s args = + makeTestSuite . Case s . fmap make . quickCheckWithResult args {chatty=False} + where + make qc = + case qc of + Success {} -> + mempty + Failure {reason = msg} -> + message msg + NoExpectedFailure {} -> + 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 + +assertNull :: Show a => String -> [a] -> TestSuite +assertNull s xs = assertMessages s (null xs) (map show xs) + +assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite +assertEquals s x y = assertMessage s (x==y) $ + "not equal " ++ show x ++ " and " ++ show y + +assertMessage :: String -> Bool -> String -> TestSuite +assertMessage s b = assertMessages s b . return + +assertMessages :: String -> Bool -> [String] -> TestSuite +assertMessages s b xs = makeTestSuite . Case s $ return $ + if b then mempty else mconcat (map message xs) + +assertIO :: String -> IO Bool -> TestSuite +assertIO s = makeTestSuite . Case s . fmap f + where + f b = if b then mempty else message "assertion failed" + +assertMessageIO :: String -> IO Message -> TestSuite +assertMessageIO s = makeTestSuite . Case s + +-- | All errors are turned into warnings +onlyWarnings :: TestSuite -> TestSuite +onlyWarnings = changeMessages $ \m -> + m { messageStatus = messageStatus m `min` Warning + , messageRating = mempty + } + +rateOnError :: Int -> TestSuite -> TestSuite +rateOnError n = changeMessages $ \m -> + if isError m then m { messageRating = Rating n } else m + +changeMessages :: (Message -> Message) -> TestSuite -> TestSuite +changeMessages f = changeTS + where + changeTS (TS xs) = TS (fmap changeTest xs) + changeTest (Case s io) = Case s (f <$> io) + changeTest (Suite s t) = Suite s (changeTS t) + +---------------------------------------------------------------- +-- Running a test suite + +runTestSuite :: Bool -> TestSuite -> IO () +runTestSuite chattyIO = void . runTestSuiteResult chattyIO + +runTestSuiteResult :: Bool -> TestSuite -> IO Result +runTestSuiteResult chattyIO ts = do + hSetBuffering stdout NoBuffering + ref <- newIORef 0 + result <- runner ref chattyIO ts + newline ref + return result + +runner :: IORef Int -> Bool -> TestSuite -> IO Result +runner ref chattyIO = runTS + where + runTS :: TestSuite -> IO Result + runTS ts = do + (res, dt) <- getDiffTime (foldM addTest mempty (tests ts)) + returnStrict res { diffTime = dt } + + runTest :: Test -> IO Result + runTest t = + case t of + Suite s xs -> runSuite s xs + Case s io -> runTestCase s io + + runSuite ::String -> TestSuite -> IO Result + runSuite s ts = do + when chattyIO $ do + newline ref + putStrLn s + reset ref + result <- runTS ts + returnStrict (suiteResult s result) + + runTestCase :: String -> IO Message -> IO Result + runTestCase s io = do + msg <- io `catch` handler + case messageStatus msg of + _ | not chattyIO -> return () + Ok -> dot ref + _ -> do + newlineIndent ref + print msg + reset ref + returnStrict (caseResult (s, msg)) + where + handler :: SomeException -> IO Message + handler = return . message . show + + addTest :: Result -> Test -> IO Result + addTest res t = (res <>) <$> runTest t + +-- formatting helpers +type WriteIO a = IORef Int -> IO a + +newline :: WriteIO () +newline ref = do + i <- readIORef ref + when (i>0) (putChar '\n') + reset ref + +newlineIndent :: WriteIO () +newlineIndent ref = do + newline ref + putStr " " + writeIORef ref 3 + +dot :: WriteIO () +dot ref = do + i <- readIORef ref + unless (i>0 && i<60) (newlineIndent ref) + putChar '.' + modifyIORef ref (+1) + +reset :: WriteIO () +reset = (`writeIORef` 0) + +---------------------------------------------------------------- +-- Test Suite Result + +data Result = Result + { suites :: S.Seq (String, Result) + , cases :: S.Seq (String, Message) + , diffTime :: !NominalDiffTime + , nrOfTests :: !Int + , nrOfWarnings :: !Int + , nrOfErrors :: !Int + , resultRating :: !Rating + } + +-- one-line summary +instance Show Result where + show result = + "(tests: " ++ show (nrOfTests result) ++ + ", errors: " ++ show (nrOfErrors result) ++ + ", warnings: " ++ show (nrOfWarnings result) ++ + ", " ++ show (diffTime result) ++ ")" + +instance Monoid Result where + mempty = Result mempty mempty 0 0 0 0 mempty + x `mappend` y = Result + { suites = suites x <> suites y + , cases = cases x <> cases y + , diffTime = diffTime x + diffTime y + , nrOfTests = nrOfTests x + nrOfTests y + , nrOfWarnings = nrOfWarnings x + nrOfWarnings y + , nrOfErrors = nrOfErrors x + nrOfErrors y + , resultRating = resultRating x <> resultRating y + } + +instance HasStatus Result where + getStatus r | nrOfErrors r > 0 = Error + | nrOfWarnings r > 0 = Warning + | otherwise = Ok + +instance HasRating Result where + rating = rating . resultRating + rate n a = a {resultRating = Rating n} + +suiteResult :: String -> Result -> Result +suiteResult s res = mempty + { suites = S.singleton (s, res) + , nrOfTests = nrOfTests res + , nrOfWarnings = nrOfWarnings res + , nrOfErrors = nrOfErrors res + , resultRating = resultRating res + } + +caseResult :: (String, Message) -> Result +caseResult x@(_, msg) = + case getStatus msg of + Ok -> new + Warning -> new { nrOfWarnings = 1 } + Error -> new { nrOfErrors = 1 } + where + new = mempty + { cases = S.singleton x + , nrOfTests = 1 + , resultRating = messageRating msg + } + +subResults :: Result -> [(String, Result)] +subResults = toList . suites + +topMessages :: Result -> [(String, Message)] +topMessages = toList . cases + +allMessages :: Result -> [(String, Message)] +allMessages res = + topMessages res ++ concatMap (allMessages . snd) (subResults res) + +findSubResult :: String -> Result -> Maybe Result +findSubResult name = listToMaybe . recs + where + recs = concatMap rec . subResults + rec (n, t) + | n == name = [t] + | otherwise = recs t + +justOneSuite :: Result -> Maybe (String, Result) +justOneSuite res = + case subResults res of + [x] | S.null (cases res) -> Just x + _ -> Nothing + +timeInterval :: Result -> Double +timeInterval = fromRational . toRational . diffTime + +printSummary :: Result -> IO () +printSummary = putStrLn . makeSummary + +makeSummary :: Result -> String +makeSummary result = unlines $ + [ line + , "Tests : " ++ show (nrOfTests result) + , "Errors : " ++ show (nrOfErrors result) + , "Warnings : " ++ show (nrOfWarnings result) + , "" + , "Time : " ++ show (diffTime result) + , "" + , "Suites: " + ] ++ map f (subResults result) + ++ [line] + where + line = replicate 75 '-' + f (name, r) = " " ++ name ++ " " ++ show r + +----------------------------------------------------- +-- Message + +data Message = M + { messageStatus :: !Status + , messageRating :: !Rating + , messageLines :: [String] + } + deriving Eq + +instance Show Message where + show a = st ++ sep ++ msg + where + msg = intercalate ", " (messageLines a) + sep = if null st || null msg then "" else ": " + st | isError a = "error" + | isWarning a = "warning" + | null (messageLines a) = "ok" + | otherwise = "" + +instance Monoid Message where + mempty = M mempty mempty mempty + M s r xs `mappend` M t q ys = M (s <> t) (r <> q) (xs <> ys) + +instance HasStatus Message where + getStatus = messageStatus + +instance HasRating Message where + rating = rating . messageRating + rate n a = a {messageRating = Rating n} + +message :: String -> Message +message = M Error (Rating 0) . return + +warning :: String -> Message +warning = M Warning mempty . return + +----------------------------------------------------- +-- Status + +data Status = Ok | Warning | Error + deriving (Eq, Ord) + +instance Monoid Status where + mempty = Ok + mappend = max + +class HasStatus a where + getStatus :: a -> Status + +isOk, isWarning, isError :: HasStatus a => a -> Bool +isOk = (== Ok) . getStatus +isWarning = (== Warning) . getStatus +isError = (== Error) . getStatus + +----------------------------------------------------- +-- Rating + +data Rating = Rating !Int | MaxRating + deriving (Eq, Ord) + +instance Monoid Rating where + mempty = MaxRating + mappend = min + +class HasRating a where + rating :: a -> Maybe Int + rate :: Int -> a -> a + +instance HasRating Rating where + rating (Rating n) = Just n + rating MaxRating = Nothing + rate = const . Rating + +----------------------------------------------------- +-- Utility function + +getDiffTime :: IO a -> IO (a, NominalDiffTime) +getDiffTime action = do + t0 <- getCurrentTime + a <- action + t1 <- getCurrentTime + return (a, diffUTCTime t1 t0) + +returnStrict :: Monad m => a -> m a +returnStrict a = a `seq` return a diff --git a/src/Ideas/Utils/Typeable.hs b/src/Ideas/Utils/Typeable.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Utils/Typeable.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Typeable type class, with the IsTypeable data type for witnessing instances +-- +----------------------------------------------------------------------------- + +module Ideas.Utils.Typeable + ( IsTypeable, typeable + , HasTypeable(..) + , castFrom, castTo, castBetween + , gcastFrom, gcastTo, gcastBetween + , module Data.Typeable + ) where + +import Control.Monad +import Data.Typeable +import Unsafe.Coerce + +newtype IsTypeable a = IT TypeRep + +class HasTypeable f where + getTypeable :: f a -> Maybe (IsTypeable a) + +instance HasTypeable IsTypeable where + getTypeable = Just + +typeable :: forall a . Typeable a => IsTypeable a +typeable = IT (typeRep (Proxy :: Proxy a)) + +castFrom :: (HasTypeable f, Typeable b) => f a -> a -> Maybe b +castFrom = flip castBetween typeable + +castTo :: (HasTypeable f, Typeable a) => f b -> a -> Maybe b +castTo = castBetween typeable + +castBetween :: (HasTypeable f, HasTypeable g) => f a -> g b -> a -> Maybe b +castBetween x y a = do + guardEq x y + return $ unsafeCoerce a + +gcastFrom :: (HasTypeable f, Typeable b) => f a -> c a -> Maybe (c b) +gcastFrom = flip gcastBetween typeable + +gcastTo :: (HasTypeable f, Typeable a) => f b -> c a -> Maybe (c b) +gcastTo = gcastBetween typeable + +gcastBetween :: (HasTypeable f, HasTypeable g) => f a -> g b -> c a -> Maybe (c b) +gcastBetween ta tb x = fmap (\Refl -> x) (eqIT ta tb) + +eqIT :: (HasTypeable f, HasTypeable g) => f a -> g b -> Maybe (a :~: b) +eqIT x y = do + guardEq x y + return $ unsafeCoerce Refl + +guardEq :: (HasTypeable f, HasTypeable g) => f a -> g b -> Maybe () +guardEq x y = do + IT ta <- getTypeable x + IT tb <- getTypeable y + guard (ta == tb) diff --git a/src/Ideas/Utils/Uniplate.hs b/src/Ideas/Utils/Uniplate.hs new file mode 100644 --- /dev/null +++ b/src/Ideas/Utils/Uniplate.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- 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. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- Exports a subset of Data.Generics.Uniplate.Direct (the @Uniplate@ type +-- class and its utility plus constructor functions) +-- +----------------------------------------------------------------------------- + +module Ideas.Utils.Uniplate + ( -- * Uniplate type class and utility functions + Uniplate + , children, contexts, descend, descendM, holes, para + , rewrite, rewriteM, transform, transformM, uniplate, universe + -- * Instance constructors + , (|-), (|*), (||*), plate + ) where + +import Data.Generics.Uniplate.Direct