ideas 1.1 → 1.2
raw patch · 101 files changed
+2654/−1712 lines, 101 filesdep +arraydep +wl-pprintdep −mtlPVP ok
version bump matches the API change (PVP)
Dependencies added: array, wl-pprint
Dependencies removed: mtl
API changes (from Hackage documentation)
- Ideas.Common.Context: data Location
- Ideas.Common.Context: location :: Navigator a => a -> Location
- Ideas.Common.Exercise: checkExamples :: Exercise a -> TestSuite
- Ideas.Common.Exercise: checkExercise :: Exercise a -> IO ()
- Ideas.Common.Exercise: checkParserPretty :: (a -> a -> Bool) -> (String -> Either String a) -> (a -> String) -> a -> Bool
- Ideas.Common.Exercise: defaultDerivation :: Exercise a -> a -> ExerciseDerivation a
- Ideas.Common.Exercise: derivationDiffEnv :: Derivation s (Context a) -> Derivation (s, Environment) (Context a)
- Ideas.Common.Exercise: difference :: Exercise a -> a -> a -> Maybe (a, a)
- Ideas.Common.Exercise: differenceEqual :: Exercise a -> a -> a -> Maybe (a, a)
- Ideas.Common.Exercise: exerciseTestSuite :: Exercise a -> TestSuite
- Ideas.Common.Exercise: instance Show (ShowAs a)
- Ideas.Common.Exercise: makeContext :: Exercise a -> Environment -> a -> Context a
- Ideas.Common.Exercise: randomTermWith :: StdGen -> Exercise a -> Maybe Difficulty -> Maybe a
- Ideas.Common.Exercise: recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [(Location, Environment)]
- Ideas.Common.Exercise: restrictGenerator :: (a -> Bool) -> Gen a -> Gen a
- Ideas.Common.Exercise: ruleOrderingWithId :: HasId b => [b] -> Rule a -> Rule a -> Ordering
- Ideas.Common.Exercise: simpleEquivalence :: Exercise a -> a -> a -> Bool
- Ideas.Common.Exercise: simpleSimilarity :: Exercise a -> a -> a -> Bool
- Ideas.Common.Exercise: type ExerciseDerivation a = Derivation (Rule (Context a), Environment) (Context a)
- Ideas.Common.Id: isEmptyId :: Id -> Bool
- Ideas.Common.Id: listQualify :: (IsId a, IsId b) => [a] -> b -> Id
- Ideas.Common.Id: mempty :: Monoid a => a
- Ideas.Common.Id: sameId :: (IsId a, IsId b) => a -> b -> Bool
- Ideas.Common.Strategy: data Prefix a
- Ideas.Common.Strategy.Core: (.%.) :: GCore l a -> GCore l a -> GCore l a
- Ideas.Common.Strategy.Core: (.*.) :: GCore l a -> GCore l a -> GCore l a
- Ideas.Common.Strategy.Core: (.|.) :: GCore l a -> GCore l a -> GCore l a
- Ideas.Common.Strategy.Core: (:!%:) :: GCore l a -> GCore l a -> GCore l a
- Ideas.Common.Strategy.Core: Many :: (GCore l a) -> GCore l a
- Ideas.Common.Strategy.Core: Not :: (GCore l a) -> GCore l a
- Ideas.Common.Strategy.Core: Rec :: Int -> (GCore l a) -> GCore l a
- Ideas.Common.Strategy.Core: Repeat :: (GCore l a) -> GCore l a
- Ideas.Common.Strategy.Core: coreMany :: GCore l a -> GCore l a
- Ideas.Common.Strategy.Core: coreOrElse :: GCore l a -> GCore l a -> GCore l a
- Ideas.Common.Strategy.Core: coreRepeat :: GCore l a -> GCore l a
- Ideas.Common.Strategy.Core: instance Foldable (GCore l)
- Ideas.Common.Strategy.Core: instance Traversable (GCore l)
- Ideas.Common.Strategy.Parsing: Ready :: Result a
- Ideas.Common.Strategy.Parsing: Result :: a -> Result a
- Ideas.Common.Strategy.Parsing: data Result a
- Ideas.Common.Strategy.Parsing: data State l a
- Ideas.Common.Strategy.Parsing: firsts :: Bool -> State l a -> [(Result (Step l a), State l a)]
- Ideas.Common.Strategy.Parsing: instance (Show l, Show a) => Show (State l a)
- Ideas.Common.Strategy.Parsing: instance Functor Result
- Ideas.Common.Strategy.Parsing: instance Show a => Show (Result a)
- Ideas.Common.Strategy.Parsing: instance Show l => Show (Stack l a)
- Ideas.Common.Strategy.Parsing: instance Show l => Show (Step l a)
- Ideas.Common.Strategy.Parsing: isReady :: Result a -> Bool
- Ideas.Common.Strategy.Parsing: stack :: State l a -> Stack l a
- Ideas.Common.Strategy.Parsing: value :: State l a -> a
- Ideas.Common.Strategy.Prefix: data Prefix a
- Ideas.Common.Strategy.Prefix: instance Eq (Prefix a)
- Ideas.Common.Strategy.Prefix: instance Show (Prefix a)
- Ideas.Common.Utils.TestSuite: addProperty :: Testable prop => String -> prop -> TestSuite
- Ideas.Common.Utils.TestSuite: addPropertyWith :: Testable prop => String -> Args -> prop -> TestSuite
- Ideas.Common.Utils.TestSuite: class Monad m => MonadIO (m :: * -> *)
- Ideas.Common.Utils.TestSuite: data TestSuiteResult
- Ideas.Common.Utils.TestSuite: instance Monad TestSuiteM
- Ideas.Common.Utils.TestSuite: instance MonadIO TestSuiteM
- Ideas.Common.Utils.TestSuite: instance Monoid TestSuiteResult
- Ideas.Common.Utils.TestSuite: instance Monoid a => Monoid (TestSuiteM a)
- Ideas.Common.Utils.TestSuite: instance Show TestSuiteResult
- Ideas.Common.Utils.TestSuite: liftIO :: MonadIO m => IO a -> m a
- Ideas.Common.Utils.TestSuite: messageLabel :: Message -> Maybe String
- Ideas.Common.Utils.TestSuite: messages :: TestSuiteResult -> [Message]
- Ideas.Common.Utils.TestSuite: newMessage :: String -> Message
- Ideas.Common.Utils.TestSuite: numberOfTests :: TestSuiteResult -> Int
- Ideas.Common.Utils.TestSuite: type TestSuite = TestSuiteM ()
- Ideas.Common.Utils.TestSuite: warn :: String -> TestSuite
- Ideas.Encoding.LinkManager: urlForResource :: LinkManager -> String -> String
- Ideas.Service.BasicServices: generateWith :: StdGen -> Exercise a -> Maybe Difficulty -> Either String (State a)
- Ideas.Service.Request: HTMLEncoding :: Encoding
- Ideas.Service.Request: OpenMath :: Encoding
- Ideas.Service.Request: StringEncoding :: Encoding
- Ideas.Text.JSON: showCompact :: JSON -> String
- Ideas.Text.JSON: showPretty :: JSON -> String
- Ideas.Text.XML: showXML :: XML -> String
- Ideas.Text.XML.Unicode: combiningCharMap :: [(Char, Char)]
- Ideas.Text.XML.Unicode: digitMap :: [(Char, Char)]
- Ideas.Text.XML.Unicode: extenderMap :: [(Char, Char)]
- Ideas.Text.XML.Unicode: letterMap :: [(Char, Char)]
+ Ideas.Common.Exercise: NewExercise :: Id -> Status -> (String -> Either String a) -> (a -> String) -> (Context a -> Context a -> Bool) -> (Context a -> Context a -> Bool) -> Predicate a -> Predicate a -> LabeledStrategy (Context a) -> Bool -> [Rule (Context a)] -> (Rule (Context a) -> Rule (Context a) -> Ordering) -> (a -> ContextNavigator a) -> Examples a -> Maybe (StdGen -> Maybe Difficulty -> a) -> Maybe (Gen a) -> Maybe (View Term a) -> Maybe (IsTypeable a) -> Map String Dynamic -> Exercise a
+ Ideas.Common.Exercise: diffEnvironment :: HasEnvironment a => Derivation s a -> Derivation (s, Environment) a
+ Ideas.Common.Exercise: getProperty :: Typeable val => String -> Exercise a -> Maybe val
+ Ideas.Common.Exercise: instance Data Difficulty
+ Ideas.Common.Exercise: instance Typeable Difficulty
+ Ideas.Common.Exercise: printDerivations :: Exercise a -> a -> IO ()
+ Ideas.Common.Exercise: properties :: Exercise a -> Map String Dynamic
+ Ideas.Common.Exercise: randomTerms :: StdGen -> Exercise a -> Maybe Difficulty -> [a]
+ Ideas.Common.Exercise: setProperty :: Typeable val => String -> val -> Exercise a -> Exercise a
+ Ideas.Common.Exercise: showDerivations :: Exercise a -> a -> String
+ Ideas.Common.ExerciseTests: S :: (a -> String) -> a -> ShowAs a
+ Ideas.Common.ExerciseTests: checkExamples :: StdGen -> Exercise a -> TestSuite
+ Ideas.Common.ExerciseTests: checkExercise :: Exercise a -> IO ()
+ Ideas.Common.ExerciseTests: checkParserPretty :: (a -> a -> Bool) -> (String -> Either String a) -> (a -> String) -> a -> Bool
+ Ideas.Common.ExerciseTests: checkParserPrettyEx :: Exercise a -> Context a -> Bool
+ Ideas.Common.ExerciseTests: checksForDerivation :: Exercise a -> Derivation (Rule (Context a), Environment) (Context a) -> [TestSuite]
+ Ideas.Common.ExerciseTests: checksForTerm :: Bool -> StdGen -> Exercise a -> a -> [TestSuite]
+ Ideas.Common.ExerciseTests: data ShowAs a
+ Ideas.Common.ExerciseTests: exerciseTestSuite :: StdGen -> Exercise a -> TestSuite
+ Ideas.Common.ExerciseTests: fromS :: ShowAs a -> a
+ Ideas.Common.ExerciseTests: instance Show (ShowAs a)
+ Ideas.Common.ExerciseTests: propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property
+ Ideas.Common.ExerciseTests: showAs :: (a -> String) -> Gen a -> Gen (ShowAs a)
+ Ideas.Common.ExerciseTests: showS :: ShowAs a -> a -> String
+ Ideas.Common.Strategy: activeLabels :: Prefix a -> [LabelInfo]
+ Ideas.Common.Strategy: data Path
+ Ideas.Common.Strategy: dependencyGraph :: IsStrategy f => DependencyGraph (f a) key -> Strategy a
+ Ideas.Common.Strategy: emptyPath :: Path
+ Ideas.Common.Strategy: showPrefix :: Prefix a -> String
+ Ideas.Common.Strategy: type DependencyGraph node key = (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
+ Ideas.Common.Strategy: type Prefix = ParseState LabelInfo
+ Ideas.Common.Strategy.Combinators: (<@>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a
+ Ideas.Common.Strategy.Combinators: dependencyGraph :: IsStrategy f => DependencyGraph (f a) key -> Strategy a
+ Ideas.Common.Strategy.Combinators: type DependencyGraph node key = (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)
+ Ideas.Common.Strategy.Core: (:@:) :: GCore l a -> GCore l a -> GCore l a
+ Ideas.Common.Strategy.Core: Let :: (CoreEnv l a) -> (GCore l a) -> GCore l a
+ Ideas.Common.Strategy.Core: coreSubstAll :: GCore l a -> GCore l a
+ Ideas.Common.Strategy.Core: instance Sequential (GCore l)
+ Ideas.Common.Strategy.Parsing: data ParseState l a
+ Ideas.Common.Strategy.Parsing: instance Show (Step l a)
+ Ideas.Common.Strategy.Parsing: searchModeState :: (Step l a -> Bool) -> (Step l a -> Step l a -> Bool) -> ParseState l a -> ParseState l a
+ Ideas.Common.Strategy.Parsing: toProcess :: Core l a -> Process (Step l a)
+ Ideas.Common.Strategy.Path: data Path
+ Ideas.Common.Strategy.Path: emptyPath :: Path
+ Ideas.Common.Strategy.Path: instance Eq Path
+ Ideas.Common.Strategy.Path: instance Read Path
+ Ideas.Common.Strategy.Path: instance Show Path
+ Ideas.Common.Strategy.Path: leftOrRight :: Monad m => Path -> m (Either Path Path)
+ Ideas.Common.Strategy.Path: tick :: Path -> Path
+ Ideas.Common.Strategy.Path: toLeft :: Path -> Path
+ Ideas.Common.Strategy.Path: toRight :: Path -> Path
+ Ideas.Common.Strategy.Path: untick :: Monad m => Path -> m Path
+ Ideas.Common.Strategy.Prefix: searchModePrefix :: (Step LabelInfo a -> Bool) -> (Step LabelInfo a -> Step LabelInfo a -> Bool) -> Prefix a -> Prefix a
+ Ideas.Common.Strategy.Prefix: showPrefix :: Prefix a -> String
+ Ideas.Common.Strategy.Prefix: type Prefix = ParseState LabelInfo
+ Ideas.Common.Strategy.Sequential: (<*>) :: Sequential f => f a -> f a -> f a
+ Ideas.Common.Strategy.Sequential: (<?>) :: Sequential f => f a -> f a -> f a
+ Ideas.Common.Strategy.Sequential: (<@>) :: Sequential f => Process a -> Process a -> f a
+ Ideas.Common.Strategy.Sequential: (<|>) :: Sequential f => f a -> f a -> f a
+ Ideas.Common.Strategy.Sequential: (~>) :: Sequential f => a -> f a -> f a
+ Ideas.Common.Strategy.Sequential: Composed :: (Process a) -> Sym a
+ Ideas.Common.Strategy.Sequential: Single :: a -> Sym a
+ Ideas.Common.Strategy.Sequential: atomic :: Sequential f => Process (Sym a) -> f (Sym a)
+ Ideas.Common.Strategy.Sequential: build :: Builder a -> Process a
+ Ideas.Common.Strategy.Sequential: choice :: Sequential f => [f a] -> f a
+ Ideas.Common.Strategy.Sequential: class Sequential f where single a = a ~> ok a ~> p = single a <*> p p <?> q = p <|> q choice = foldr (<|>) stop
+ Ideas.Common.Strategy.Sequential: concurrent :: Sequential f => (a -> Bool) -> Process a -> Process a -> f a
+ Ideas.Common.Strategy.Sequential: data Builder a
+ Ideas.Common.Strategy.Sequential: data Process a
+ Ideas.Common.Strategy.Sequential: data Sym a
+ Ideas.Common.Strategy.Sequential: empty :: Process a -> Bool
+ Ideas.Common.Strategy.Sequential: firsts :: Process a -> [(a, Process a)]
+ Ideas.Common.Strategy.Sequential: fromAtoms :: Process (Sym a) -> Process a
+ Ideas.Common.Strategy.Sequential: instance Eq a => Eq (Process a)
+ Ideas.Common.Strategy.Sequential: instance Sequential Builder
+ Ideas.Common.Strategy.Sequential: instance Sequential Process
+ Ideas.Common.Strategy.Sequential: instance Show a => Show (Process a)
+ Ideas.Common.Strategy.Sequential: ok, stop :: Sequential f => f a
+ Ideas.Common.Strategy.Sequential: prune :: (a -> Bool) -> Process a -> Process a
+ Ideas.Common.Strategy.Sequential: replay :: Monad m => Path -> Process a -> m ([a], Process a)
+ Ideas.Common.Strategy.Sequential: scanChoice :: (a -> b -> [(a, c)]) -> a -> Process b -> Process c
+ Ideas.Common.Strategy.Sequential: single :: Sequential f => a -> f a
+ Ideas.Common.Strategy.Sequential: tidyProcess :: (a -> a -> Bool) -> (a -> Bool) -> Process a -> Process a
+ Ideas.Common.Strategy.Sequential: uniquePath :: (a -> Bool) -> (a -> a -> Bool) -> Process a -> Process a
+ Ideas.Common.Strategy.Sequential: withPath :: Process a -> Process (a, Path)
+ Ideas.Common.Strategy.Traversal: leftmost :: Option a
+ Ideas.Common.Strategy.Traversal: leftmostbu :: (IsStrategy f, Navigator a) => f a -> Strategy a
+ Ideas.Common.Strategy.Traversal: leftmosttd :: (IsStrategy f, Navigator a) => f a -> Strategy a
+ Ideas.Common.Strategy.Traversal: rightmost :: Option a
+ Ideas.Common.Strategy.Traversal: ruleDown :: Navigator a => Rule a
+ Ideas.Common.Strategy.Traversal: ruleDownLast :: Navigator a => Rule a
+ Ideas.Common.Strategy.Traversal: ruleUp :: Navigator a => Rule a
+ Ideas.Common.Utils.TestSuite: allMessages :: Result -> [(String, Message)]
+ Ideas.Common.Utils.TestSuite: assertMessage :: String -> Bool -> String -> TestSuite
+ Ideas.Common.Utils.TestSuite: assertMessageIO :: String -> IO Message -> TestSuite
+ Ideas.Common.Utils.TestSuite: class HasRating a
+ Ideas.Common.Utils.TestSuite: class HasStatus a
+ Ideas.Common.Utils.TestSuite: data Rating
+ Ideas.Common.Utils.TestSuite: data Result
+ Ideas.Common.Utils.TestSuite: data Status
+ Ideas.Common.Utils.TestSuite: data TestSuite
+ Ideas.Common.Utils.TestSuite: getStatus :: HasStatus a => a -> Status
+ Ideas.Common.Utils.TestSuite: instance Eq Message
+ Ideas.Common.Utils.TestSuite: instance Eq Rating
+ Ideas.Common.Utils.TestSuite: instance Eq Status
+ Ideas.Common.Utils.TestSuite: instance HasRating Message
+ Ideas.Common.Utils.TestSuite: instance HasRating Rating
+ Ideas.Common.Utils.TestSuite: instance HasRating Result
+ Ideas.Common.Utils.TestSuite: instance HasStatus Message
+ Ideas.Common.Utils.TestSuite: instance HasStatus Result
+ Ideas.Common.Utils.TestSuite: instance Monoid Message
+ Ideas.Common.Utils.TestSuite: instance Monoid Rating
+ Ideas.Common.Utils.TestSuite: instance Monoid Result
+ Ideas.Common.Utils.TestSuite: instance Monoid Status
+ Ideas.Common.Utils.TestSuite: instance Monoid TestSuite
+ Ideas.Common.Utils.TestSuite: instance Ord Rating
+ Ideas.Common.Utils.TestSuite: instance Ord Status
+ Ideas.Common.Utils.TestSuite: instance Show Result
+ Ideas.Common.Utils.TestSuite: isOk :: HasStatus a => a -> Bool
+ Ideas.Common.Utils.TestSuite: isWarning :: HasStatus a => a -> Bool
+ Ideas.Common.Utils.TestSuite: justOneSuite :: Result -> Maybe (String, Result)
+ Ideas.Common.Utils.TestSuite: message :: String -> Message
+ Ideas.Common.Utils.TestSuite: messageLines :: Message -> [String]
+ Ideas.Common.Utils.TestSuite: nrOfErrors :: Result -> Int
+ Ideas.Common.Utils.TestSuite: nrOfTests :: Result -> Int
+ Ideas.Common.Utils.TestSuite: nrOfWarnings :: Result -> Int
+ Ideas.Common.Utils.TestSuite: onlyWarnings :: TestSuite -> TestSuite
+ Ideas.Common.Utils.TestSuite: rate :: HasRating a => Int -> a -> a
+ Ideas.Common.Utils.TestSuite: rateOnError :: Int -> TestSuite -> TestSuite
+ Ideas.Common.Utils.TestSuite: rating :: HasRating a => a -> Maybe Int
+ Ideas.Common.Utils.TestSuite: timeInterval :: Result -> Double
+ Ideas.Common.Utils.TestSuite: useProperty :: Testable prop => String -> prop -> TestSuite
+ Ideas.Common.Utils.TestSuite: usePropertyWith :: Testable prop => String -> Args -> prop -> TestSuite
+ Ideas.Encoding.LinkManager: linkToTestReport :: LinkManager -> Exercise a -> HTMLBuilder -> HTMLBuilder
+ Ideas.Encoding.LinkManager: urlForCSS :: LinkManager -> String -> String
+ Ideas.Encoding.LinkManager: urlForImage :: LinkManager -> String -> String
+ Ideas.Encoding.LinkManager: urlForTestReport :: LinkManager -> forall a. Exercise a -> String
+ Ideas.Main.Default: Some :: (f a) -> Some f
+ Ideas.Main.Default: data Service
+ Ideas.Main.Default: data Some f
+ Ideas.Main.Default: metaServiceList :: DomainReasoner -> [Service]
+ Ideas.Main.Default: serviceList :: [Service]
+ Ideas.Service.BasicServices: create :: Exercise a -> String -> Either String (State a)
+ Ideas.Service.BasicServices: recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [(Location, Environment)]
+ Ideas.Service.Diagnose: Unknown :: Bool -> (State a) -> Diagnosis a
+ Ideas.Service.Diagnose: WrongRule :: Bool -> (State a) -> (Maybe (Rule (Context a))) -> Diagnosis a
+ Ideas.Service.Diagnose: difference :: Exercise a -> a -> a -> Maybe (a, a)
+ Ideas.Service.Diagnose: differenceEqual :: Exercise a -> a -> a -> Maybe (a, a)
+ Ideas.Service.FeedbackScript.Run: motivation :: Environment a -> Maybe (Rule (Context a))
+ Ideas.Service.FeedbackScript.Syntax: MotivationIs :: Id -> Condition
+ Ideas.Service.Request: EncCompact :: Encoding
+ Ideas.Service.Request: EncHTML :: Encoding
+ Ideas.Service.Request: EncOpenMath :: Encoding
+ Ideas.Service.Request: EncPretty :: Encoding
+ Ideas.Service.Request: EncString :: Encoding
+ Ideas.Service.Request: compactOutput :: Request -> Bool
+ Ideas.Service.Request: compactOutputDefault :: Bool -> Request -> Bool
+ Ideas.Service.Request: htmlOutput :: Request -> Bool
+ Ideas.Service.Request: useLogging :: Request -> Bool
+ Ideas.Service.Request: useOpenMath :: Request -> Bool
+ Ideas.Service.Types: IO :: TypeRep f t -> TypeRep f (IO t)
+ Ideas.Service.Types: Result :: Const a Result
+ Ideas.Service.Types: instance Typed a Result
+ Ideas.Service.Types: instance Typed a t => Typed a (IO t)
+ Ideas.Text.JSON: compactJSON :: JSON -> String
+ Ideas.Text.XML: parseXMLFile :: FilePath -> IO XML
+ Ideas.Text.XML.Document: instance Pretty Attribute
+ Ideas.Text.XML.Document: instance Pretty Element
+ Ideas.Text.XML.Document: instance Pretty Parameter
+ Ideas.Text.XML.Document: instance Pretty Reference
+ Ideas.Text.XML.Document: instance Pretty XML
+ Ideas.Text.XML.Document: prettyElement :: Bool -> Element -> Doc
+ Ideas.Text.XML.Document: prettyXML :: Bool -> XML -> Doc
+ Ideas.Text.XML.Interface: compactXML :: Element -> String
- Ideas.Common.Context: newContext :: Environment -> ContextNavigator a -> Context a
+ Ideas.Common.Context: newContext :: ContextNavigator a -> Context a
- Ideas.Common.Exercise: examples :: Exercise a -> [(Difficulty, a)]
+ Ideas.Common.Exercise: examples :: Exercise a -> Examples a
- Ideas.Common.Exercise: randomTerm :: Exercise a -> Maybe Difficulty -> IO a
+ Ideas.Common.Exercise: randomTerm :: StdGen -> Exercise a -> Maybe Difficulty -> Maybe a
- Ideas.Common.Exercise: ruleOrderingWith :: [Rule a] -> Rule a -> Rule a -> Ordering
+ Ideas.Common.Exercise: ruleOrderingWith :: HasId b => [b] -> Rule a -> Rule a -> Ordering
- Ideas.Common.Exercise: useGenerator :: (a -> Bool) -> (Maybe Difficulty -> Gen a) -> Maybe (StdGen -> Maybe Difficulty -> a)
+ Ideas.Common.Exercise: useGenerator :: (Maybe Difficulty -> Gen a) -> Maybe (StdGen -> Maybe Difficulty -> a)
- Ideas.Common.Strategy: derivationTree :: IsStrategy f => Bool -> f a -> a -> DerivationTree (Rule a, Environment) a
+ Ideas.Common.Strategy: derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a, Environment) a
- Ideas.Common.Strategy: emptyPrefix :: LabeledStrategy a -> Prefix a
+ Ideas.Common.Strategy: emptyPrefix :: LabeledStrategy a -> a -> Prefix a
- Ideas.Common.Strategy: fullDerivationTree :: IsStrategy f => Bool -> f a -> a -> DerivationTree (Step LabelInfo a) a
+ Ideas.Common.Strategy: fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Step LabelInfo a) a
- Ideas.Common.Strategy: makePrefix :: Monad m => [Int] -> LabeledStrategy a -> m (Prefix a)
+ Ideas.Common.Strategy: makePrefix :: Monad m => Path -> LabeledStrategy a -> a -> m (Prefix a)
- Ideas.Common.Strategy: prefixTree :: Bool -> Prefix a -> a -> DerivationTree (Prefix a) a
+ Ideas.Common.Strategy: prefixTree :: a -> Prefix a -> DerivationTree (Prefix a) a
- Ideas.Common.Strategy.Abstract: derivationTree :: IsStrategy f => Bool -> f a -> a -> DerivationTree (Rule a, Environment) a
+ Ideas.Common.Strategy.Abstract: derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a, Environment) a
- Ideas.Common.Strategy.Abstract: fullDerivationTree :: IsStrategy f => Bool -> f a -> a -> DerivationTree (Step LabelInfo a) a
+ Ideas.Common.Strategy.Abstract: fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Step LabelInfo a) a
- Ideas.Common.Strategy.Parsing: choices :: State l a -> [Bool]
+ Ideas.Common.Strategy.Parsing: choices :: ParseState l a -> Path
- Ideas.Common.Strategy.Parsing: makeState :: Core l a -> a -> State l a
+ Ideas.Common.Strategy.Parsing: makeState :: a -> Core l a -> ParseState l a
- Ideas.Common.Strategy.Parsing: parseDerivationTree :: Bool -> State l a -> DerivationTree (Step l a) (State l a)
+ Ideas.Common.Strategy.Parsing: parseDerivationTree :: a -> ParseState l a -> DerivationTree (Step l a) (a, ParseState l a)
- Ideas.Common.Strategy.Parsing: replay :: Monad m => Int -> [Bool] -> Core l a -> m (State l a)
+ Ideas.Common.Strategy.Parsing: replay :: Monad m => Path -> a -> Core l a -> m (ParseState l a)
- Ideas.Common.Strategy.Parsing: trace :: State l a -> [Step l a]
+ Ideas.Common.Strategy.Parsing: trace :: ParseState l a -> [Step l a]
- Ideas.Common.Strategy.Prefix: emptyPrefix :: LabeledStrategy a -> Prefix a
+ Ideas.Common.Strategy.Prefix: emptyPrefix :: LabeledStrategy a -> a -> Prefix a
- Ideas.Common.Strategy.Prefix: makePrefix :: Monad m => [Int] -> LabeledStrategy a -> m (Prefix a)
+ Ideas.Common.Strategy.Prefix: makePrefix :: Monad m => Path -> LabeledStrategy a -> a -> m (Prefix a)
- Ideas.Common.Strategy.Prefix: prefixTree :: Bool -> Prefix a -> a -> DerivationTree (Prefix a) a
+ Ideas.Common.Strategy.Prefix: prefixTree :: a -> Prefix a -> DerivationTree (Prefix a) a
- Ideas.Common.Utils.TestSuite: findSubResult :: String -> TestSuiteResult -> Maybe TestSuiteResult
+ Ideas.Common.Utils.TestSuite: findSubResult :: String -> Result -> Maybe Result
- Ideas.Common.Utils.TestSuite: isError :: Message -> Bool
+ Ideas.Common.Utils.TestSuite: isError :: HasStatus a => a -> Bool
- Ideas.Common.Utils.TestSuite: makeSummary :: TestSuiteResult -> String
+ Ideas.Common.Utils.TestSuite: makeSummary :: Result -> String
- Ideas.Common.Utils.TestSuite: printSummary :: TestSuiteResult -> IO ()
+ Ideas.Common.Utils.TestSuite: printSummary :: Result -> IO ()
- Ideas.Common.Utils.TestSuite: runTestSuite :: TestSuite -> IO ()
+ Ideas.Common.Utils.TestSuite: runTestSuite :: Bool -> TestSuite -> IO ()
- Ideas.Common.Utils.TestSuite: runTestSuiteResult :: TestSuite -> IO TestSuiteResult
+ Ideas.Common.Utils.TestSuite: runTestSuiteResult :: Bool -> TestSuite -> IO Result
- Ideas.Common.Utils.TestSuite: subResults :: TestSuiteResult -> [(String, TestSuiteResult)]
+ Ideas.Common.Utils.TestSuite: subResults :: Result -> [(String, Result)]
- Ideas.Common.Utils.TestSuite: suite :: String -> TestSuite -> TestSuite
+ Ideas.Common.Utils.TestSuite: suite :: String -> [TestSuite] -> TestSuite
- Ideas.Common.Utils.TestSuite: topMessages :: TestSuiteResult -> [Message]
+ Ideas.Common.Utils.TestSuite: topMessages :: Result -> [(String, Message)]
- Ideas.Common.Utils.TestSuite: warning :: Message -> Message
+ Ideas.Common.Utils.TestSuite: warning :: String -> Message
- Ideas.Encoding.Evaluator: Evaluator :: (TypedValue (Type a) -> m b) -> (forall t. Type a t -> m t) -> Evaluator a m b
+ Ideas.Encoding.Evaluator: Evaluator :: (TypedValue (Type a) -> IO b) -> (forall t. Type a t -> IO t) -> Evaluator a b
- Ideas.Encoding.Evaluator: data Evaluator a m b
+ Ideas.Encoding.Evaluator: data Evaluator a b
- Ideas.Encoding.Evaluator: evalService :: Monad m => Evaluator a m b -> Service -> m b
+ Ideas.Encoding.Evaluator: evalService :: Evaluator a b -> Service -> IO b
- Ideas.Encoding.LinkManager: LinkManager :: (String -> String) -> String -> Bool -> String -> String -> String -> (Service -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> Rule (Context a) -> String) -> (forall a. Exercise a -> Difficulty -> String) -> (forall a. State a -> String) -> (forall a. State a -> String) -> (forall a. State a -> String) -> (forall a. State a -> String) -> LinkManager
+ Ideas.Encoding.LinkManager: LinkManager :: (String -> String) -> (String -> String) -> String -> Bool -> String -> String -> String -> (Service -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> Rule (Context a) -> String) -> (forall a. Exercise a -> String) -> (forall a. Exercise a -> Difficulty -> String) -> (forall a. State a -> String) -> (forall a. State a -> String) -> (forall a. State a -> String) -> (forall a. State a -> String) -> LinkManager
- Ideas.Encoding.ModeJSON: processJSON :: Bool -> DomainReasoner -> String -> IO (Request, String, String)
+ Ideas.Encoding.ModeJSON: processJSON :: Maybe Int -> Bool -> DomainReasoner -> String -> IO (Request, String, String)
- Ideas.Encoding.ModeXML: processXML :: DomainReasoner -> Maybe String -> String -> IO (Request, String, String)
+ Ideas.Encoding.ModeXML: processXML :: Maybe Int -> DomainReasoner -> Maybe String -> String -> IO (Request, String, String)
- Ideas.Service.BasicServices: generate :: Exercise a -> Maybe Difficulty -> IO (State a)
+ Ideas.Service.BasicServices: generate :: StdGen -> Exercise a -> Maybe Difficulty -> Either String (State a)
- Ideas.Service.Diagnose: NotEquivalent :: Diagnosis a
+ Ideas.Service.Diagnose: NotEquivalent :: String -> Diagnosis a
- Ideas.Service.Diagnose: diagnose :: State a -> Context a -> Diagnosis a
+ Ideas.Service.Diagnose: diagnose :: State a -> Context a -> Maybe Id -> Diagnosis a
- Ideas.Service.FeedbackScript.Run: Env :: Bool -> Maybe (Rule (Context a)) -> Maybe (Rule (Context a)) -> Maybe [LabelInfo] -> Maybe (String, String) -> Maybe Term -> Maybe Term -> Maybe String -> Environment a
+ Ideas.Service.FeedbackScript.Run: Env :: Bool -> Maybe (Rule (Context a)) -> Maybe (Rule (Context a)) -> Maybe (Rule (Context a)) -> Maybe [LabelInfo] -> Maybe (String, String) -> Maybe Term -> Maybe Term -> Maybe String -> Environment a
- Ideas.Service.FeedbackScript.Run: feedbackHints :: Id -> [((Rule (Context a), b, c), State a)] -> State a -> Script -> [Text]
+ Ideas.Service.FeedbackScript.Run: feedbackHints :: Id -> [((Rule (Context a), b, c), State a)] -> State a -> Maybe (Rule (Context a)) -> Script -> [Text]
- Ideas.Service.FeedbackScript.Run: newEnvironment :: State a -> Environment a
+ Ideas.Service.FeedbackScript.Run: newEnvironment :: State a -> Maybe (Rule (Context a)) -> Environment a
- Ideas.Service.FeedbackText: feedbacktext :: Script -> State a -> Context a -> (Message, State a)
+ Ideas.Service.FeedbackText: feedbacktext :: Script -> State a -> Context a -> Maybe Id -> (Message, State a)
- Ideas.Service.Request: Request :: String -> Maybe Id -> Maybe String -> DataFormat -> Maybe Encoding -> Request
+ Ideas.Service.Request: Request :: String -> Maybe Id -> Maybe String -> DataFormat -> [Encoding] -> Request
- Ideas.Service.Request: encoding :: Request -> Maybe Encoding
+ Ideas.Service.Request: encoding :: Request -> [Encoding]
- Ideas.Service.Request: readEncoding :: Monad m => String -> m Encoding
+ Ideas.Service.Request: readEncoding :: Monad m => String -> m [Encoding]
- Ideas.Service.Submit: NotEquivalent :: Result a
+ Ideas.Service.Submit: NotEquivalent :: String -> Result a
- Ideas.Text.JSON: jsonRPC :: (MonadError a m, InJSON a) => JSON -> RPCHandler m -> m RPCResponse
+ Ideas.Text.JSON: jsonRPC :: JSON -> RPCHandler -> IO RPCResponse
- Ideas.Text.JSON: type RPCHandler m = String -> JSON -> m JSON
+ Ideas.Text.JSON: type RPCHandler = String -> JSON -> IO JSON
- Ideas.Text.XML: compactXML :: XML -> String
+ Ideas.Text.XML: compactXML :: Element -> String
Files
- ideas.cabal +12/−8
- src/Ideas/Common/Algebra/Boolean.hs +3/−1
- src/Ideas/Common/Algebra/BooleanLaws.hs +3/−1
- src/Ideas/Common/Algebra/Field.hs +3/−1
- src/Ideas/Common/Algebra/FieldLaws.hs +3/−1
- src/Ideas/Common/Algebra/Group.hs +3/−1
- src/Ideas/Common/Algebra/GroupLaws.hs +3/−1
- src/Ideas/Common/Algebra/Law.hs +3/−1
- src/Ideas/Common/Algebra/SmartGroup.hs +3/−1
- src/Ideas/Common/Classes.hs +3/−1
- src/Ideas/Common/Context.hs +13/−10
- src/Ideas/Common/Derivation.hs +3/−1
- src/Ideas/Common/DerivationTree.hs +3/−1
- src/Ideas/Common/Environment.hs +3/−1
- src/Ideas/Common/Exercise.hs +282/−364
- src/Ideas/Common/ExerciseTests.hs +182/−0
- src/Ideas/Common/Id.hs +62/−30
- src/Ideas/Common/Library.hs +5/−2
- src/Ideas/Common/Predicate.hs +4/−2
- src/Ideas/Common/Rewriting.hs +3/−1
- src/Ideas/Common/Rewriting/AC.hs +3/−1
- src/Ideas/Common/Rewriting/Confluence.hs +3/−1
- src/Ideas/Common/Rewriting/Difference.hs +3/−1
- src/Ideas/Common/Rewriting/RewriteRule.hs +3/−1
- src/Ideas/Common/Rewriting/Substitution.hs +20/−17
- src/Ideas/Common/Rewriting/Term.hs +3/−1
- src/Ideas/Common/Rewriting/Unification.hs +23/−20
- src/Ideas/Common/Rule.hs +3/−1
- src/Ideas/Common/Rule/Abstract.hs +3/−1
- src/Ideas/Common/Rule/EnvironmentMonad.hs +18/−17
- src/Ideas/Common/Rule/Parameter.hs +3/−1
- src/Ideas/Common/Rule/Recognizer.hs +3/−1
- src/Ideas/Common/Rule/Transformation.hs +3/−1
- src/Ideas/Common/Strategy.hs +8/−3
- src/Ideas/Common/Strategy/Abstract.hs +15/−10
- src/Ideas/Common/Strategy/Combinators.hs +39/−9
- src/Ideas/Common/Strategy/Configuration.hs +3/−1
- src/Ideas/Common/Strategy/Core.hs +47/−85
- src/Ideas/Common/Strategy/Location.hs +3/−2
- src/Ideas/Common/Strategy/Parsing.hs +88/−239
- src/Ideas/Common/Strategy/Path.hs +70/−0
- src/Ideas/Common/Strategy/Prefix.hs +20/−29
- src/Ideas/Common/Strategy/Sequential.hs +326/−0
- src/Ideas/Common/Strategy/Tests.hs +39/−32
- src/Ideas/Common/Strategy/Traversal.hs +21/−5
- src/Ideas/Common/Traversal/Iterator.hs +3/−1
- src/Ideas/Common/Traversal/Navigator.hs +3/−1
- src/Ideas/Common/Traversal/Tests.hs +78/−67
- src/Ideas/Common/Traversal/Utils.hs +3/−1
- src/Ideas/Common/Utils.hs +3/−1
- src/Ideas/Common/Utils/QuickCheck.hs +3/−1
- src/Ideas/Common/Utils/StringRef.hs +3/−1
- src/Ideas/Common/Utils/TestSuite.hs +321/−200
- src/Ideas/Common/Utils/Uniplate.hs +3/−1
- src/Ideas/Common/View.hs +4/−2
- src/Ideas/Encoding/DecoderJSON.hs +17/−9
- src/Ideas/Encoding/DecoderXML.hs +16/−16
- src/Ideas/Encoding/EncoderHTML.hs +94/−18
- src/Ideas/Encoding/EncoderJSON.hs +20/−10
- src/Ideas/Encoding/EncoderXML.hs +12/−4
- src/Ideas/Encoding/Evaluator.hs +13/−34
- src/Ideas/Encoding/LinkManager.hs +16/−6
- src/Ideas/Encoding/ModeJSON.hs +20/−16
- src/Ideas/Encoding/ModeXML.hs +34/−25
- src/Ideas/Encoding/OpenMathSupport.hs +3/−1
- src/Ideas/Encoding/RulePresenter.hs +3/−1
- src/Ideas/Encoding/RulesInfo.hs +4/−2
- src/Ideas/Encoding/StrategyInfo.hs +8/−15
- src/Ideas/Main/BlackBoxTests.hs +38/−43
- src/Ideas/Main/Default.hs +21/−11
- src/Ideas/Main/Documentation.hs +3/−1
- src/Ideas/Main/LoggingDatabase.hs +5/−3
- src/Ideas/Main/Options.hs +3/−3
- src/Ideas/Main/Revision.hs +3/−3
- src/Ideas/Service/BasicServices.hs +32/−11
- src/Ideas/Service/Diagnose.hs +58/−15
- src/Ideas/Service/DomainReasoner.hs +3/−1
- src/Ideas/Service/FeedbackScript/Analysis.hs +8/−8
- src/Ideas/Service/FeedbackScript/Parser.hs +9/−3
- src/Ideas/Service/FeedbackScript/Run.hs +41/−25
- src/Ideas/Service/FeedbackScript/Syntax.hs +9/−5
- src/Ideas/Service/FeedbackText.hs +20/−15
- src/Ideas/Service/ProblemDecomposition.hs +22/−21
- src/Ideas/Service/Request.hs +49/−11
- src/Ideas/Service/ServiceList.hs +20/−5
- src/Ideas/Service/State.hs +7/−6
- src/Ideas/Service/Submit.hs +20/−15
- src/Ideas/Service/Types.hs +18/−1
- src/Ideas/Text/HTML.hs +4/−2
- src/Ideas/Text/JSON.hs +54/−48
- src/Ideas/Text/OpenMath/FMP.hs +3/−1
- src/Ideas/Text/OpenMath/Object.hs +3/−1
- src/Ideas/Text/OpenMath/Symbol.hs +3/−1
- src/Ideas/Text/OpenMath/Tests.hs +3/−1
- src/Ideas/Text/Parsing.hs +3/−1
- src/Ideas/Text/UTF8.hs +4/−2
- src/Ideas/Text/XML.hs +11/−19
- src/Ideas/Text/XML/Document.hs +67/−38
- src/Ideas/Text/XML/Interface.hs +8/−3
- src/Ideas/Text/XML/Parser.hs +9/−7
- src/Ideas/Text/XML/Unicode.hs +40/−41
ideas.cabal view
@@ -1,5 +1,5 @@ name: ideas-version: 1.1+version: 1.2 synopsis: Feedback services for intelligent tutoring systems homepage: http://ideas.cs.uu.nl/www/ description:@@ -9,7 +9,7 @@ and Activemath. category: Education-copyright: (c) 2013+copyright: (c) 2014 license: GPL license-file: LICENSE.txt author: Bastiaan Heeren, Alex Gerdes, Johan Jeuring@@ -18,7 +18,7 @@ extra-source-files: CREDITS.txt build-type: Simple cabal-version: >= 1.8.0.2-tested-with: GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1+tested-with: GHC == 7.4.1, GHC == 7.6.3 source-repository head type: svn@@ -30,16 +30,17 @@ ghc-options: -Wall hs-source-dirs: src Build-Depends: base >= 4.2 && < 5, - QuickCheck >= 2.4.1, + QuickCheck >= 2.4.1 && < 2.7, containers, random, - mtl, uniplate, time, - filepath, - directory, + filepath,+ directory, cgi, - parsec+ parsec,+ wl-pprint,+ array Exposed-modules: Ideas.Common.Algebra.Boolean@@ -56,6 +57,7 @@ Ideas.Common.DerivationTree Ideas.Common.Environment Ideas.Common.Exercise+ Ideas.Common.ExerciseTests Ideas.Common.Id Ideas.Common.Library Ideas.Common.Predicate@@ -80,7 +82,9 @@ Ideas.Common.Strategy.Core Ideas.Common.Strategy.Location Ideas.Common.Strategy.Parsing+ Ideas.Common.Strategy.Path Ideas.Common.Strategy.Prefix+ Ideas.Common.Strategy.Sequential Ideas.Common.Strategy.Tests Ideas.Common.Strategy.Traversal Ideas.Common.Traversal.Iterator
src/Ideas/Common/Algebra/Boolean.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Boolean.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Algebra.Boolean ( -- * Boolean algebra BoolValue(..), Boolean(..)
src/Ideas/Common/Algebra/BooleanLaws.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: BooleanLaws.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Algebra.BooleanLaws ( -- * Boolean laws andOverOrLaws, orOverAndLaws
src/Ideas/Common/Algebra/Field.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Field.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Algebra.Field ( -- * Semi-ring SemiRing(..)
src/Ideas/Common/Algebra/FieldLaws.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: FieldLaws.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Algebra.FieldLaws ( -- * Semi-ring laws leftDistributive, rightDistributive
src/Ideas/Common/Algebra/Group.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Group.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Algebra.Group ( -- * Monoids Monoid(..), (<>)
src/Ideas/Common/Algebra/GroupLaws.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: GroupLaws.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Algebra.GroupLaws ( -- * Monoid laws associative, leftIdentity
src/Ideas/Common/Algebra/Law.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Law.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Algebra.Law ( Law, LawSpec((:==:)), law, mapLaw , propertyLaw, rewriteLaw
src/Ideas/Common/Algebra/SmartGroup.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: SmartGroup.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Algebra.SmartGroup ( -- * Smart datatypes Smart(..), SmartZero(..), SmartGroup(..)
src/Ideas/Common/Classes.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Type classes and instances. -- ----------------------------------------------------------------------------- +-- $Id: Classes.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Classes ( -- * Type class Apply Apply, apply, applyAll, applicable, applyD, applyM, applyList
src/Ideas/Common/Context.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,15 +9,19 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- A context for a term that maintains an environment of --- key-value pairs. A context is both showable and parsable. -- +-- The 'Context' datatype places a value in a context consisting of an +-- environment with bindings and a point of focus. The datatype is an instance +-- of the 'HasEnvironment' type class (for accessing the environment) and +-- the 'Navigator' type class (for traversing the term). +-- ----------------------------------------------------------------------------- +-- $Id: Context.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Context ( -- * Abstract data type Context, newContext , fromContext, fromContextWith, fromContextWith2 - , Location, location -- * Context navigator , ContextNavigator, noNavigator, navigator, termNavigator -- * Lifting @@ -39,11 +43,10 @@ ---------------------------------------------------------- -- Abstract data type --- | Abstract data type for a context: a context stores an envrionent --- (key-value pairs) and a value +-- | Abstract data type for a context: a context stores an envrionent. data Context a = C - { getEnvironment :: Environment -- ^ Returns the environment - , getNavigator :: ContextNavigator a -- ^ Value with focus + { getEnvironment :: Environment + , getNavigator :: ContextNavigator a } fromContext :: Monad m => Context a -> m a @@ -79,8 +82,8 @@ setEnvironment e c = c {getEnvironment = e} -- | Construct a context -newContext :: Environment -> ContextNavigator a -> Context a -newContext = C +newContext :: ContextNavigator a -> Context a +newContext = C mempty ---------------------------------------------------------- -- Context navigator
src/Ideas/Common/Derivation.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- and the steps) -- ----------------------------------------------------------------------------- +-- $Id: Derivation.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Derivation ( -- * Data type Derivation
src/Ideas/Common/DerivationTree.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- intermediate results as well as annotations for the steps. -- ----------------------------------------------------------------------------- +-- $Id: DerivationTree.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.DerivationTree ( -- * Data types DerivationTree
src/Ideas/Common/Environment.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- References, bindings, and heterogenous environments -- ----------------------------------------------------------------------------- +-- $Id: Environment.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Environment ( -- * Reference Ref, Reference(..)
src/Ideas/Common/Exercise.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types, DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,44 +9,45 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- This module defines the concept of an exercise +-- The 'Exercise' record defines all the components that are needed for +-- calculating feedback for one class of exercises. The fields of an exercise +-- have to be consistent; consistency can be checked with the +-- "Ideas.Common.ExerciseTests" module. -- ----------------------------------------------------------------------------- +-- $Id: Exercise.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Exercise - ( -- * Exercises - Exercise, makeExercise, emptyExercise - , exerciseId, status, parser, prettyPrinter - , equivalence, similarity, ready, suitable, isReady, isSuitable - , hasTermView - , strategy, navigation, canBeRestarted, extraRules, ruleOrdering - , difference, differenceEqual - , testGenerator, randomExercise, examples, getRule - , simpleGenerator, useGenerator - , randomTerm, randomTermWith, ruleset - , makeContext, inContext, recognizeRule - , ruleOrderingWith, ruleOrderingWithId - , Examples, mapExamples, examplesContext - , Difficulty(..), readDifficulty, level - , hasTypeable, useTypeable, castFrom, castTo - -- * Exercise status + ( -- * Exercise record + Exercise(..), emptyExercise, makeExercise + -- * Convenience functions + , prettyPrinterContext, isReady, isSuitable + , ruleset, getRule, ruleOrderingWith + -- * Status , Status(..), isPublic, isPrivate - -- * Miscellaneous - , withoutContext, simpleSimilarity, simpleEquivalence - , prettyPrinterContext, restrictGenerator - , showDerivation, printDerivation - , ExerciseDerivation, defaultDerivation - , derivationDiffEnv - , checkExercise, checkParserPretty - , checkExamples, exerciseTestSuite + -- * Examples + , Examples, Difficulty(..), readDifficulty + , level, mapExamples, examplesContext + -- * Context + , inContext, withoutContext + -- * Type casting + , useTypeable, castFrom, castTo + -- * Exercise properties + , setProperty, getProperty + -- * Random generators + , simpleGenerator, useGenerator, randomTerm, randomTerms + -- * Derivations + , showDerivation, showDerivations, printDerivation, printDerivations + , diffEnvironment ) where -import Control.Monad.Error import Data.Char +import Data.Data +import Data.Dynamic import Data.Function import Data.List import Data.Maybe import Data.Ord -import Data.Typeable import Ideas.Common.Classes import Ideas.Common.Context import Ideas.Common.Derivation @@ -57,40 +58,80 @@ import Ideas.Common.Rewriting import Ideas.Common.Rule import Ideas.Common.Strategy hiding (not, fail, repeat, replicate) -import Ideas.Common.Traversal.Navigator (top, downs) import Ideas.Common.Utils (ShowString(..)) -import Ideas.Common.Utils.TestSuite import Ideas.Common.View import System.Random import Test.QuickCheck hiding (label) import Test.QuickCheck.Gen -import qualified Ideas.Common.Rewriting.Difference as Diff +import qualified Data.Map as M import qualified Ideas.Common.Strategy as S -data Exercise a = Exercise - { -- identification and meta-information - exerciseId :: Id -- identifier that uniquely determines the exercise - , status :: Status - -- parsing and pretty-printing - , parser :: String -> Either String a - , prettyPrinter :: a -> String - -- syntactic and semantic checks - , equivalence :: Context a -> Context a -> Bool - , similarity :: Context a -> Context a -> Bool -- possibly more liberal than syntactic equality - , ready :: Predicate a - , suitable :: Predicate a - , hasTermView :: Maybe (View Term a) - , hasTypeable :: Maybe (IsTypeable a) - -- strategies and rules - , strategy :: LabeledStrategy (Context a) - , navigation :: a -> ContextNavigator a - , canBeRestarted :: Bool -- By default, assumed to be the case - , extraRules :: [Rule (Context a)] -- Extra rules (possibly buggy) not appearing in strategy - , ruleOrdering :: Rule (Context a) -> Rule (Context a) -> Ordering -- Ordering on rules (for onefirst) - -- testing and exercise generation - , testGenerator :: Maybe (Gen a) +----------------------------------------------------------------------------- +-- Exercise record + +-- | For constructing an empty exercise, use function 'emptyExercise' or +-- 'makeExercise'. +data Exercise a = + NewExercise + { -- | Identifier that uniquely determines the exercise: see 'HasId' for + -- how to use values with identifiers. + exerciseId :: Id + -- | The status of the exercise. + , status :: Status + -- | Parser for expressions of the exercise class, which either results + -- in an error ('Left') or a result ('Right'). + , parser :: String -> Either String a + -- | Pretty-printer for expressions of the exercise class. Pretty-printing + -- should be the inverse of parsing. + , prettyPrinter :: a -> String + -- | Tests wether two expressions (with their contexts) are semantically + -- equivalent. Use 'withoutContext' for defining the equivalence check + -- when the context is not relevant. + , equivalence :: Context a -> Context a -> Bool + -- | Tests wether two expressions (with their contexts) are syntactically + -- the same, or nearly so. Expressions that are similar must also be + -- equivalent. Use 'withoutContext' if the context is not relevant for the + -- similarity check. + , similarity :: Context a -> Context a -> Bool + -- | Predicate suitable identifies which expressions can be solved by the + -- strategy of the exercise class. It acts as the pre-condition of the + -- strategy. + , suitable :: Predicate a + -- | Predicate ready checks if an expression is in a solved form (accepted + -- as a final solution). It acts as the post-condition of the strategy. + , ready :: Predicate a + -- | The rewrite strategy that specifies how to solve an exercise. + , strategy :: LabeledStrategy (Context a) + -- | Is it possible to restart the rewrite strategy at any point in time? + -- Restarting the strategy is needed when a student deviates from the + -- strategy (detour). By default, restarting is assumed to be possible. + , canBeRestarted :: Bool + -- | Are there extra rules, possibly buggy, that do not appear in the + -- strategy? Use 'ruleset' to get all rules. + , extraRules :: [Rule (Context a)] + -- | The rule ordering is a tiebreaker in situations where more than one + -- rule can be used (e.g. feedback services onefirst and derivation; other + -- feedback services return all possible rules). + , ruleOrdering :: Rule (Context a) -> Rule (Context a) -> Ordering + -- | A navigator is needed for traversing the expression and for using the + -- traversal strategy combinators. By default, an exercise has no + -- navigator. + , navigation :: a -> ContextNavigator a + -- | A finite list of examples, each with an assigned difficulty. + , examples :: Examples a + -- | A generator for random exercises of a certain difficulty. , randomExercise :: Maybe (StdGen -> Maybe Difficulty -> a) - , examples :: [(Difficulty, a)] + -- | An exercise generator for testing purposes (including corner cases). + , testGenerator :: Maybe (Gen a) + -- | Conversion to and from the (generic) 'Term' datatype. Needed for + -- representing the expression in the OpenMath standard. + , hasTermView :: Maybe (View Term a) + -- | Representation of the type of expression: this provides a back door + -- for exercise-specific functionality. + , hasTypeable :: Maybe (IsTypeable a) + -- | Extra exercise-specific properties, not used by the default + -- feedback services. + , properties :: M.Map String Dynamic -- extra, domain-specific properties } instance Eq (Exercise a) where @@ -106,15 +147,10 @@ getId = exerciseId changeId f ex = ex { exerciseId = f (exerciseId ex) } -makeExercise :: (Show a, Eq a, IsTerm a) => Exercise a -makeExercise = emptyExercise - { prettyPrinter = show - , similarity = (==) - , hasTermView = Just termView - } - +-- | The 'emptyExercise' constructor function provides sensible defaults for +-- all fields of the 'Exercise' record. emptyExercise :: Exercise a -emptyExercise = Exercise +emptyExercise = NewExercise { -- identification and meta-information exerciseId = mempty , status = Experimental @@ -128,6 +164,7 @@ , suitable = true , hasTermView = Nothing , hasTypeable = Nothing + , properties = M.empty -- strategies and rules , strategy = label "Fail" S.fail , navigation = noNavigator @@ -140,32 +177,92 @@ , examples = [] } -makeContext :: Exercise a -> Environment -> a -> Context a -makeContext ex env = newContext env . navigation ex +-- | In addition to the defaults of 'emptyExercise', this constructor sets +-- the fields 'prettyPrinter', 'similarity', and 'hasTermView'. +makeExercise :: (Show a, Eq a, IsTerm a) => Exercise a +makeExercise = emptyExercise + { prettyPrinter = show + , similarity = (==) + , hasTermView = Just termView + } --- | Put a value into an empty environment -inContext :: Exercise a -> a -> Context a -inContext = flip makeContext mempty +----------------------------------------------------------------------------- +-- Convenience functions ---------------------------------------------------------------- --- Difficulty levels +-- | Pretty print a value in its context. +prettyPrinterContext :: Exercise a -> Context a -> String +prettyPrinterContext ex = + maybe "<<invalid term>>" (prettyPrinter ex) . fromContext -type Examples a = [(Difficulty, a)] +-- | Checks if an expression is in a solved form. +isReady :: Exercise a -> a -> Bool +isReady = evalPredicate . ready -mapExamples :: (a -> b) -> Examples a -> Examples b -mapExamples f = map (second f) +-- | Checks if the expression is suitable and can be solved by the strategy. +isSuitable :: Exercise a -> a -> Bool +isSuitable = evalPredicate . suitable -examplesContext :: Exercise a -> Examples (Context a) -examplesContext ex = mapExamples (inContext ex) (examples ex) +-- | Returns a sorted list of rules, without duplicates. +ruleset :: Exercise a -> [Rule (Context a)] +ruleset ex = nub (sortBy compareId list) + where + list = extraRules ex ++ rulesInStrategy (strategy ex) +-- | Finds a rule of an exercise based on its identifier. +getRule :: Monad m => Exercise a -> Id -> m (Rule (Context a)) +getRule ex a = + case filter ((a ==) . getId) (ruleset ex) of + [hd] -> return hd + [] -> fail $ "Could not find ruleid " ++ showId a + _ -> fail $ "Ambiguous ruleid " ++ showId a + +-- | Makes a rule ordering based on a list of values with identifiers (e.g., +-- a list of rules). Rules with identifiers that are not in the list are +-- considered after the rules in the list, and are sorted based on their +-- identifier. +ruleOrderingWith :: HasId b => [b] -> Rule a -> Rule a -> Ordering +ruleOrderingWith bs r1 r2 = + let xs = map getId bs in + case (elemIndex (getId r1) xs, elemIndex (getId r2) xs) of + (Just i, Just j ) -> i `compare` j + (Just _, Nothing) -> LT + (Nothing, Just _ ) -> GT + (Nothing, Nothing) -> compareId r1 r2 + +----------------------------------------------------------------------------- +-- Status + +-- | The status of an exercise class. +data Status + = Stable -- ^ A released exercise that has undergone some thorough testing + | Provisional -- ^ A released exercise, possibly with some deficiencies + | Alpha -- ^ An exercise that is under development + | Experimental -- ^ An exercise for experimentation purposes only + deriving (Show, Eq) + +-- | An exercise with the status 'Stable' or 'Provisional' +isPublic :: Exercise a -> Bool +isPublic ex = status ex `elem` [Stable, Provisional] + +-- | An exercise that is not public +isPrivate :: Exercise a -> Bool +isPrivate = not . isPublic + +----------------------------------------------------------------------------- +-- Examples + +type Examples a = [(Difficulty, a)] + data Difficulty = VeryEasy | Easy | Medium | Difficult | VeryDifficult - deriving (Eq, Ord, Enum) + deriving (Eq, Ord, Enum, Data, Typeable) instance Show Difficulty where show = (xs !!) . fromEnum where xs = ["very_easy", "easy", "medium", "difficult", "very_difficult"] +-- | Parser for difficulty levels, which ignores non-alpha charactes (including +-- spaces) and upper/lower case distinction. readDifficulty :: String -> Maybe Difficulty readDifficulty s = case filter p [VeryEasy .. VeryDifficult] of @@ -175,342 +272,163 @@ normal = filter isAlpha . map toLower p = (== normal s) . normal . show +-- | Assigns a difficulty level to a list of expressions. level :: Difficulty -> [a] -> Examples a level = zip . repeat ---------------------------------------------------------------- --- Exercise generators - --- returns a sorted list of rules (no duplicates) -ruleset :: Exercise a -> [Rule (Context a)] -ruleset ex = nub (sortBy compareId list) - where - list = extraRules ex ++ rulesInStrategy (strategy ex) - -simpleGenerator :: Gen a -> Maybe (StdGen -> Maybe Difficulty -> a) -simpleGenerator = useGenerator (const True) . const - -useGenerator :: (a -> Bool) -> (Maybe Difficulty -> Gen a) -> Maybe (StdGen -> Maybe Difficulty -> a) -useGenerator p makeGen = Just (\rng -> rec rng . makeGen) - where - rec rng gen@(MkGen f) - | p a = a - | otherwise = rec (snd (next rng)) gen - where - (size, r) = randomR (0, 100) rng - a = f r size - -restrictGenerator :: (a -> Bool) -> Gen a -> Gen a -restrictGenerator p g = do - a <- g - if p a then return a - else restrictGenerator p g - -randomTerm :: Exercise a -> Maybe Difficulty -> IO a -randomTerm ex mdif = do - rng <- newStdGen - maybe (fail "no random term") return $ randomTermWith rng ex mdif - -randomTermWith :: StdGen -> Exercise a -> Maybe Difficulty -> Maybe a -randomTermWith rng ex mdif = - case randomExercise ex of - Just f -> return (f rng mdif) - Nothing - | null xs -> Nothing - | otherwise -> Just $ - snd $ xs !! fst (randomR (0, length xs - 1) rng) - where - xs = filter p (examples ex) - p (d, _) = maybe True (==d) mdif - -difference :: Exercise a -> a -> a -> Maybe (a, a) -difference ex a b = do - v <- hasTermView ex - Diff.differenceWith v a b +mapExamples :: (a -> b) -> Examples a -> Examples b +mapExamples f = map (second f) -differenceEqual :: Exercise a -> a -> a -> Maybe (a, a) -differenceEqual ex a b = do - v <- hasTermView ex - Diff.differenceEqualWith v (simpleEquivalence ex) a b +-- | Returns the examples of an exercise class lifted to a context. +examplesContext :: Exercise a -> Examples (Context a) +examplesContext ex = mapExamples (inContext ex) (examples ex) --- Recognize a rule at (possibly multiple) locations -recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [(Location, Environment)] -recognizeRule ex r ca cb = rec (top ca) - where - final = addTransRecognizer (similarity ex) r - rec x = do - -- here - as <- recognizeAll final x cb - return (location x, as) - `mplus` -- or there - concatMap rec (downs x) +----------------------------------------------------------------------------- +-- Context -ruleOrderingWith :: [Rule a] -> Rule a -> Rule a -> Ordering -ruleOrderingWith = ruleOrderingWithId . map getId +-- | Puts a value into a context with an empty environment. +inContext :: Exercise a -> a -> Context a +inContext ex = newContext . navigation ex -ruleOrderingWithId :: HasId b => [b] -> Rule a -> Rule a -> Ordering -ruleOrderingWithId bs r1 r2 = - let xs = map getId bs in - case (elemIndex (getId r1) xs, elemIndex (getId r2) xs) of - (Just i, Just j ) -> i `compare` j - (Just _, Nothing) -> LT - (Nothing, Just _ ) -> GT - (Nothing, Nothing) -> compareId r1 r2 +-- | Function for defining equivalence or similarity without taking +-- the context into account. +withoutContext :: (a -> a -> Bool) -> Context a -> Context a -> Bool +withoutContext f a b = fromMaybe False (fromContextWith2 f a b) ---------------------------------------------------------------- --- Using type representations for casts +----------------------------------------------------------------------------- +-- Type casting data IsTypeable a = IT (forall b . Typeable b => a -> Maybe b) (forall b . Typeable b => b -> Maybe a) +-- | 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 ---------------------------------------------------------------- --- Exercise status - -data Status - = Stable -- ^ A released exercise that has undergone some thorough testing - | Provisional -- ^ A released exercise, possibly with some deficiencies - | Alpha -- ^ An exercise that is under development - | Experimental -- ^ An exercise for experimentation purposes only - deriving (Show, Eq) +----------------------------------------------------------------------------- +-- Exercise-specific properties --- | An exercise with the status @Stable@ or @Provisional@ -isPublic :: Exercise a -> Bool -isPublic ex = status ex `elem` [Stable, Provisional] +-- | 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) } --- | An exercise that is not public -isPrivate :: Exercise a -> Bool -isPrivate = not . isPublic +-- | 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 --------------------------------------------------------------- --- Rest +-- Random generators --- | Function for defining equivalence or similarity without taking --- the context into account. -withoutContext :: (a -> a -> Bool) -> Context a -> Context a -> Bool -withoutContext f a b = fromMaybe False (fromContextWith2 f a b) +-- | Makes a random exercise generator from a QuickCheck generator; the exercise +-- generator ignores the difficulty level. See the 'randomExercise' field. +simpleGenerator :: Gen a -> Maybe (StdGen -> Maybe Difficulty -> a) +simpleGenerator = useGenerator . const -isReady :: Exercise a -> a -> Bool -isReady = evalPredicate . ready +-- | Makes a random exercise generator based on a QuickCheck generator for a +-- particular difficulty level. See the 'randomExercise' field. +useGenerator :: (Maybe Difficulty -> Gen a) -> Maybe (StdGen -> Maybe Difficulty -> a) +useGenerator makeGen = Just (\rng -> rec rng . makeGen) + where + rec rng (MkGen f) = a + where + (size, r) = randomR (0, 100) rng + a = f r size -isSuitable :: Exercise a -> a -> Bool -isSuitable = evalPredicate . suitable +-- | Returns a random exercise of a certain difficulty with some random +-- number generator. The field 'randomExercise' is used; if this is not +-- defined (i.e., Nothing), one of the examples is used instead. +randomTerm :: StdGen -> Exercise a -> Maybe Difficulty -> Maybe a +randomTerm rng ex mdif = + case randomExercise ex of + Just f -> return (f rng mdif) + Nothing + | null xs -> Nothing + | otherwise -> Just (snd (xs !! i)) + where + xs = filter p (examples ex) + p (d, _) = maybe True (==d) mdif + i = fst (randomR (0, length xs - 1) rng) --- | Similarity on terms without a context -simpleSimilarity :: Exercise a -> a -> a -> Bool -simpleSimilarity ex = similarity ex `on` inContext ex +-- | Returns a list of randomly generated terms of a certain difficulty. +randomTerms :: StdGen -> Exercise a -> Maybe Difficulty -> [a] +randomTerms rng ex mdif = rec rng + where + rec a = maybe id (:) (randomTerm a ex mdif) (rec (snd (next a))) --- | Equivalence on terms without a context -simpleEquivalence :: Exercise a -> a -> a -> Bool -simpleEquivalence ex = equivalence ex `on` inContext ex +--------------------------------------------------------------- +-- Derivations -prettyPrinterContext :: Exercise a -> Context a -> String -prettyPrinterContext ex = - maybe "<<invalid term>>" (prettyPrinter ex) . fromContext +-- | Shows the default derivation for a given start term. The specified rule ordering +-- is used for selection. +showDerivation :: Exercise a -> a -> String +showDerivation ex a = showThisDerivation (defaultDerivation ex a) ex -getRule :: Monad m => Exercise a -> Id -> m (Rule (Context a)) -getRule ex a = - case filter ((a ==) . getId) (ruleset ex) of - [hd] -> return hd - [] -> fail $ "Could not find ruleid " ++ showId a - _ -> fail $ "Ambiguous ruleid " ++ showId a +-- | Shows all derivations for a given start term. Warning: there can be many +-- derivations. +showDerivations :: Exercise a -> a -> String +showDerivations ex a = unlines + [ "Derivation #" ++ show i ++ "\n" ++ showThisDerivation d ex + | (i, d) <- zip [1::Int ..] (allDerivations ex a) + ] --- |Shows a derivation for a given start term. The specified rule ordering +-- | Prints the default derivation for a given start term. The specified rule ordering -- is used for selection. -showDerivation :: Exercise a -> a -> String -showDerivation ex a = show (present der) ++ extra +printDerivation :: Exercise a -> a -> IO () +printDerivation ex = putStrLn . showDerivation ex + +-- | Prints all derivations for a given start term. Warning: there can be many +-- derivations. +printDerivations :: Exercise a -> a -> IO () +printDerivations ex = putStrLn . showDerivations ex + +-- also pass derivation as an argument +showThisDerivation :: Derivation (Rule b, Environment) (Context a) -> Exercise a -> String +showThisDerivation d ex = show (present der) ++ extra where - der = derivationDiffEnv (defaultDerivation ex a) + der = diffEnvironment d extra = case fromContext (lastTerm der) of Nothing -> "<<invalid term>>" Just b | isReady ex b -> "" | otherwise -> "<<not ready>>" present = biMap (ShowString . f) (ShowString . prettyPrinterContext ex) - f ((r, local), global) = showId r ++ part1 ++ part2 + f ((r, local), global) = showId r ++ part local ++ part global where - newl = "\n " - part1 = newl ++ show local - part2 | noBindings global = "" - | otherwise = newl ++ show global - -type ExerciseDerivation a = Derivation (Rule (Context a), Environment) (Context a) - -defaultDerivation :: Exercise a -> a -> ExerciseDerivation a -defaultDerivation ex a = - let ca = inContext ex a - tree = sortTree (ruleOrdering ex `on` fst) (derivationTree False (strategy ex) ca) - single = emptyDerivation ca - in fromMaybe single (derivation tree) + newl = "\n " + part env | noBindings env = "" + | otherwise = newl ++ show env -derivationDiffEnv :: Derivation s (Context a) -> Derivation (s, Environment) (Context a) -derivationDiffEnv = updateSteps $ \old a new -> - let keep x = not (getId x `sameId` "location" || x `elem` list) +-- | Adds the difference of the environments in a derivation to the steps. +-- Bindings with identifier @location@ are ignored. This utility function is +-- useful for printing derivations. +diffEnvironment :: HasEnvironment a => Derivation s a -> Derivation (s, Environment) a +diffEnvironment = updateSteps $ \old a new -> + let keep x = not (getId x == newId "location" || x `elem` list) list = bindings old in (a, makeEnvironment $ filter keep $ bindings new) -printDerivation :: Exercise a -> a -> IO () -printDerivation ex = putStrLn . showDerivation ex - ---------------------------------------------------------------- --- Checks for an exercise - -checkExercise :: Exercise a -> IO () -checkExercise = runTestSuite . exerciseTestSuite - -exerciseTestSuite :: Exercise a -> TestSuite -exerciseTestSuite ex = suite ("Exercise " ++ show (exerciseId ex)) $ do - -- get some exercises - xs <- if isJust (randomExercise ex) - then liftIO $ replicateM 10 (randomTerm ex Nothing) - else return (map snd (examples ex)) - -- do tests - assertTrue "Exercise terms defined" (not (null xs)) - assertTrue "Equivalence implemented" $ - let eq a b = equivalence ex (inContext ex a) (inContext ex b) - in length (nubBy eq xs) > 1 - assertTrue "Similarity implemented" $ - let sim a b = similarity ex (inContext ex a) (inContext ex b) - in length (nubBy sim xs) > 1 - checkExamples ex - case testGenerator ex of - Nothing -> return () - Just gen -> do - let showAsGen = showAs (prettyPrinter ex) gen - addProperty "parser/pretty printer" $ forAll showAsGen $ - checkParserPrettyEx ex . inContext ex . fromS - - {- - suite "Soundness non-buggy rules" $ - forM_ (filter (not . isBuggyRule) $ ruleset ex) $ \r -> - let eq a b = equivalence ex (fromS a) (fromS b) - myGen = showAs (prettyPrinterContext ex) (liftM (inContext ex) gen) - myView = makeView (return . fromS) (S (prettyPrinterContext ex)) - args = stdArgs {maxSize = 10, maxSuccess = 10, maxDiscard = 100} - in addPropertyWith (showId r) args $ - propRuleSmart eq (liftView myView r) myGen -} - - addProperty "soundness strategy/generator" $ - forAll showAsGen $ - maybe False (isReady ex) . fromContext - . applyD (strategy ex) . inContext ex . fromS - -data ShowAs a = S {showS :: a -> String, fromS :: a} - -instance Show (ShowAs a) where - show a = showS a (fromS a) - -showAs :: (a -> String) -> Gen a -> Gen (ShowAs a) -showAs f = liftM (S f) - --- check combination of parser and pretty-printer -checkParserPretty :: (a -> a -> Bool) -> (String -> Either String a) -> (a -> String) -> a -> Bool -checkParserPretty eq p pretty a = - either (const False) (eq a) (p (pretty a)) - -checkParserPrettyEx :: Exercise a -> Context a -> Bool -checkParserPrettyEx ex ca = - let f = mapSecond make . parser ex - make = newContext (environment ca) . navigation ex - in checkParserPretty (similarity ex) f (prettyPrinterContext ex) ca - -{- -propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property -propRule eq r gen = - forAll gen $ \a -> - let xs = applyAll r a in - not (null xs) ==> - forAll (elements xs) $ \b -> - a `eq` b -} - -checkExamples :: Exercise a -> TestSuite -checkExamples ex = do - let xs = map snd (examples ex) - unless (null xs) $ suite "Examples" $ - mapM_ (checksForTerm True ex) xs - -checksForTerm :: Bool -> Exercise a -> a -> TestSuite -checksForTerm leftMost ex a = do - let tree = derivationTree False (strategy ex) (inContext ex a) - -- Left-most derivation - when leftMost $ - case derivation tree of - Just d -> checksForDerivation ex d - Nothing -> - fail $ "no derivation for " ++ prettyPrinter ex a - -- Random derivation - g <- liftIO getStdGen - case randomDerivation g tree of - Just d -> checksForDerivation ex d - Nothing -> return () - -checksForDerivation :: Exercise a -> Derivation (Rule (Context a), Environment) (Context a) -> TestSuite -checksForDerivation ex d = do - -- Conditions on starting term - let start = firstTerm d - assertTrue - ("start term not suitable: " ++ prettyPrinterContext ex start) $ - maybe False (isSuitable ex) (fromContext start) - - {- - b2 <- do let b = False -- maybe True (isReady ex) (fromContext start) - when b $ report $ - "start term is ready: " ++ prettyPrinterContext ex start - return b-} - -- Conditions on final term - let final = lastTerm d - {- - b3 <- do let b = False -- maybe True (isSuitable ex) (fromContext final) - when b $ report $ - "final term is suitable: " ++ prettyPrinterContext ex start - ++ " => " ++ prettyPrinterContext ex final - return b -} - assertTrue - ("final term not ready: " ++ prettyPrinterContext ex start - ++ " => " ++ prettyPrinterContext ex final) $ - maybe False (isReady ex) (fromContext final) - - -- Parser/pretty printer on terms - let ts = terms d - p1 = not . checkParserPrettyEx ex - assertNull "parser/pretty-printer" $ take 1 $ flip map (filter p1 ts) $ \hd -> - let s = prettyPrinterContext ex hd - in "parse error for " ++ s ++ ": parsed as " - ++ either show (prettyPrinter ex) (parser ex s) - - -- Equivalences between terms - let pairs = [ (x, y) | x <- ts, y <- ts ] - p2 (x, y) = not (equivalence ex x y) - assertNull "equivalences" $ take 1 $ flip map (filter p2 pairs) $ \(x, y) -> - "not equivalent: " ++ prettyPrinterContext ex x - ++ " with " ++ prettyPrinterContext ex y - - -- Similarity of terms - let p3 (x, (_, _), y) = similarity ex x y && - on (==) (maybe False (isReady ex) . fromContext) x y - assertNull "similars" $ take 1 $ flip map (filter p3 (triples d)) $ \(x, r, y) -> - "similar subsequent terms: " ++ prettyPrinterContext ex x - ++ " with " ++ prettyPrinterContext ex y - ++ " using " ++ show r - - assertNull "self similarity" $ take 1 $ do - x <- terms d - guard (not (similarity ex x x)) - return $ "term not similar to itself: " ++ prettyPrinterContext ex x +defaultDerivation :: Exercise a -> a -> Derivation (Rule (Context a), Environment) (Context a) +defaultDerivation ex a = + case allDerivations ex a of + [] -> emptyDerivation (inContext ex a) + d:_ -> d - -- Parameters - assertNull "parameters" $ take 1 $ do - (r, env) <- steps d - maybeToList (checkReferences r env)+allDerivations :: Exercise a -> a -> [Derivation (Rule (Context a), Environment) (Context a)] +allDerivations ex = + derivations . sortTree (ruleOrdering ex `on` fst) + . derivationTree (strategy ex) . inContext ex
+ src/Ideas/Common/ExerciseTests.hs view
@@ -0,0 +1,182 @@+----------------------------------------------------------------------------- +-- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +-- $Id: ExerciseTests.hs 6535 2014-05-14 11:05:06Z bastiaan $ + +module Ideas.Common.ExerciseTests where + +import Control.Monad +import Data.Function +import Data.List +import Data.Maybe +import Ideas.Common.Classes +import Ideas.Common.Context +import Ideas.Common.Derivation +import Ideas.Common.DerivationTree +import Ideas.Common.Environment +import Ideas.Common.Exercise +import Ideas.Common.Id +import Ideas.Common.Rule +import Ideas.Common.Strategy (derivationTree) +import Ideas.Common.Utils.TestSuite +import Ideas.Common.View +import System.Random +import Test.QuickCheck + +--------------------------------------------------------------- +-- Checks for an exercise + +checkExercise :: Exercise a -> IO () +checkExercise ex = do + stdgen <- getStdGen + runTestSuite True (exerciseTestSuite stdgen ex) + +exerciseTestSuite :: StdGen -> Exercise a -> TestSuite +exerciseTestSuite stdgen ex = suite ("Exercise " ++ show (exerciseId ex)) $ + [ assertTrue "exercise terms defined" (not (null xs)) + , assertTrue "equivalence implemented" $ + let eq a b = equivalence ex (inContext ex a) (inContext ex b) + in length (nubBy eq xs) > 1 + , assertTrue "similarity implemented" $ + let sim a b = similarity ex (inContext ex a) (inContext ex b) + in length (nubBy sim xs) > 1 + , checkExamples stdgen ex + ] ++ + case testGenerator ex of + Nothing -> [] + Just gen -> + [ useProperty "parser/pretty printer" $ forAll showAsGen $ + 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) + myView = makeView (Just . fromS) (S (prettyPrinterContext ex)) + args = stdArgs {maxSize = 10, maxSuccess = 10} + in [ usePropertyWith (showId r) args $ + propRule eq (liftView myView r) myGen + | r <- ruleset ex + , not (isBuggy r) + ] {- + -} + , useProperty "soundness strategy/generator" $ + forAll showAsGen $ + maybe False (isReady ex) . fromContext + . applyD (strategy ex) . inContext ex . fromS + ] + where + showAsGen = showAs (prettyPrinter ex) gen + where + xs | isJust (randomExercise ex) = + take 10 (randomTerms stdgen ex Nothing) + | otherwise = map snd (examples ex) + +data ShowAs a = S {showS :: a -> String, fromS :: a} + +instance Show (ShowAs a) where + show a = showS a (fromS a) + +showAs :: (a -> String) -> Gen a -> Gen (ShowAs a) +showAs f = liftM (S f) + +-- check combination of parser and pretty-printer +checkParserPretty :: (a -> a -> Bool) -> (String -> Either String a) -> (a -> String) -> a -> Bool +checkParserPretty eq p pretty a = + either (const False) (eq a) (p (pretty a)) + +checkParserPrettyEx :: Exercise a -> Context a -> Bool +checkParserPrettyEx ex ca = + let f = mapSecond make . parser ex + make = setEnvironment (environment ca) . newContext . navigation ex + in checkParserPretty (similarity ex) f (prettyPrinterContext ex) ca + +propRule :: Show a => (a -> a -> Bool) -> Rule a -> Gen a -> Property +propRule eq r gen = + forAll gen $ \a -> + let xs = applyAll r a in + not (null xs) ==> + forAll (elements xs) $ \b -> + a `eq` b + +checkExamples :: StdGen -> Exercise a -> TestSuite +checkExamples stdgen ex + | null xs = mempty + | otherwise = suite "Examples" $ + concatMap (checksForTerm True stdgen ex) xs + where + xs = map snd (examples ex) + +checksForTerm :: Bool -> StdGen -> Exercise a -> a -> [TestSuite] +checksForTerm leftMost stdgen ex a = + concat + -- Left-most derivation + [ case derivation tree of + Just d -> checksForDerivation ex d + Nothing -> [assertTrue ("no derivation for " ++ prettyPrinter ex a) False] + | leftMost + ] ++ + case randomDerivation stdgen tree of + Just d -> checksForDerivation ex d + Nothing -> [] + where + tree = derivationTree (strategy ex) (inContext ex a) + +checksForDerivation :: Exercise a -> Derivation (Rule (Context a), Environment) (Context a) -> [TestSuite] +checksForDerivation ex d = + [ -- Conditions on starting term + assertMessage "start term is suitable" + (maybe False (isSuitable ex) (fromContext start)) + (prettyPrinterContext ex start) + , assertMessage "start term is not ready" + (maybe True (not . isReady ex) (fromContext start)) + (prettyPrinterContext ex start) + -- Conditions on final term + , assertMessage "final term is suitable" + (maybe True (isSuitable ex) (fromContext final)) + (prettyPrinterContext ex start) + , assertMessage "final term is ready" + (maybe False (isReady ex) (fromContext final)) + (prettyPrinterContext ex start ++ " => " ++ + prettyPrinterContext ex final) + -- Parser/pretty printer on terms + , assertNull "parser/pretty-printer" $ take 1 $ flip map (filter p1 ts) $ \hd -> + let s = prettyPrinterContext ex hd + in "parse error for " ++ s ++ ": parsed as " + ++ either show (prettyPrinter ex) (parser ex s) + -- Equivalences between terms + , assertNull "equivalences" $ take 1 $ flip map (filter p2 pairs) $ \(x, y) -> + "not equivalent: " ++ prettyPrinterContext ex x + ++ " with " ++ prettyPrinterContext ex y + -- Similarity of terms + , let xs = filter p3 (triples d) in + let (x, (r, _), y) = head xs in + rateOnError 5 $ assertMessage "no similar steps" + (null xs) + ( prettyPrinterContext ex x ++ + " with " ++ prettyPrinterContext ex y ++ + " using " ++ show r) + , assertNull "self similarity" $ take 1 $ do + x <- terms d + guard (not (similarity ex x x)) + return $ "term not similar to itself: " ++ prettyPrinterContext ex x + , -- Parameters + assertNull "parameters" $ take 1 $ do + (r, env) <- steps d + maybeToList (checkReferences r env) + ] + where + start = firstTerm d + final = lastTerm d + ts = terms d + p1 = not . checkParserPrettyEx ex + pairs = [ (x, y) | x <- ts, y <- ts ] + p2 (x, y) = not (equivalence ex x y) + p3 (x, (_, _), y) = similarity ex x y && + on (==) (maybe False (isReady ex) . fromContext) x y
src/Ideas/Common/Id.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,14 +9,39 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- Identification of entities +-- Many entities of the Ideas framework carry an 'Id' for identification. +-- Identifiers have a hierarchical structure of an arbitrary depth (e.g. +-- @algebra.equation@ or @a.b.c@). Valid symbols for identifiers are the +-- alpha-numerical characters, together with @-@ and @_@. Each identifier +-- carries a description and a hash value for fast comparison. -- +-- Functionality for identifiers is provided by means of three type classes: +-- +-- * Type class 'IsId' for constructing identifiers +-- +-- * Type class 'HasId' for accessing (and changing) the identifier of an +-- entity. Instances of this type class must always have exactly one +-- identifier (although this identifier can be empty). +-- +-- * Type class 'Identify' for labeling entities with an identifier. Instances +-- of this type class typically allow labels to appear at multiple locations +-- within their structure. +-- +-- The 'Id' datatype implements and re-exports the Monoid interface. +-- ----------------------------------------------------------------------------- +-- $Id: Id.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Id - ( Id, IsId(..), HasId(..), Identify(..), ( # ), sameId - , unqualified, qualifiers, qualification + ( -- * Constructing identifiers + Id, IsId(..), ( # ) + -- * Accessing (and changing) identifiers + , HasId(..), unqualified, qualifiers, qualification , describe, description, showId, compareId - , mempty, isEmptyId, listQualify + -- * Labeling with identifiers + , Identify(..) + -- re-export + , module Data.Monoid ) where import Control.Monad @@ -33,6 +58,8 @@ --------------------------------------------------------------------- -- Abstract data type and its instances +-- | Abstract data type for identifiers with a hierarchical name, carrying +-- a description. The data type provides a fast comparison implementation. data Id = Id { idList :: [String] , idDescription :: String @@ -65,9 +92,9 @@ , (1, liftM2 mappend arbitrary arbitrary) ] ---------------------------------------------------------------------- --- Type class for constructing identifiers - +-- | Type class 'IsId' for constructing identifiers. Examples are +-- @newId \"algebra.equation\"@, @newId (\"a\", \"b\", \"c\")@, and @newId ()@ +-- for the empty identifier. class IsId a where newId :: a -> Id concatId :: [a] -> Id -- for String instance @@ -100,9 +127,20 @@ instance (IsId a, IsId b) => IsId (Either a b) where newId = either newId newId +infixr 8 # + +-- | Appends two identifiers. Both parameters are overloaded. +( # ) :: (IsId a, IsId b) => a -> b -> Id +a # b = appendId (newId a) (newId b) + ----------------------------------------------------- -- Type class for structures containing an identifier +-- | Type class for labeling entities with an identifier +class HasId a => Identify a where + (@>) :: IsId n => n -> a -> a + +-- | Type classfor accessing (and changing) the identifier of an entity. class HasId a where getId :: a -> Id changeId :: (Id -> Id) -> a -> a @@ -115,9 +153,6 @@ getId = either getId getId changeId f = biMap (changeId f) (changeId f) -class HasId a => Identify a where - (@>) :: IsId n => n -> a -> a - --------------------------------------------------------------------- -- Private constructors @@ -146,14 +181,7 @@ --------------------------------------------------------------------- -- Additional functionality (overloaded) -infixr 8 # - -( # ) :: (IsId a, IsId b) => a -> b -> Id -a # b = appendId (newId a) (newId b) - -sameId :: (IsId a, IsId b) => a -> b -> Bool -sameId a b = newId a == newId b - +-- | Get the unqualified part of the identifier (i.e., last string). unqualified :: HasId a => a -> String unqualified a | null xs = "" @@ -161,6 +189,8 @@ where xs = idList (getId a) +-- | Get the list of qualifiers of the identifier (i.e., everything but the +-- last string). qualifiers :: HasId a => a -> [String] qualifiers a | null xs = [] @@ -168,21 +198,17 @@ where xs = idList (getId a) +-- | Get the qualified part of the identifier. If the identifier consists of +-- more than one part, the parts are separated by a period (@'.'@). qualification :: HasId a => a -> String qualification = intercalate "." . qualifiers +-- | Get the current description. description :: HasId a => a -> String description = idDescription . getId -showId :: HasId a => a -> String -showId = show . getId - -compareId :: HasId a => a -> a -> Ordering -compareId = comparing showId - -isEmptyId :: Id -> Bool -isEmptyId = (== emptyId) - +-- | Give a description for the current entity. If there already is a +-- description, both strings are combined. describe :: HasId a => String -> a -> a describe = changeId . describeId where @@ -192,5 +218,11 @@ | otherwise = a {idDescription = s ++ " " ++ idDescription a} -listQualify :: (IsId a, IsId b) => [a] -> b -> Id -- TODO: clean me up -listQualify ls h = foldr (appendId . newId) (newId h) ls+-- | Show the identifier. +showId :: HasId a => a -> String +showId = show . getId + +-- | Compare two identifiers based on their names. Use @compare@ for a fast +-- ordering based on hash values. +compareId :: HasId a => a -> a -> Ordering +compareId = comparing showId
src/Ideas/Common/Library.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Exports most from package Common -- ----------------------------------------------------------------------------- +-- $Id: Library.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Library ( module Export , failS, notS, repeatS, replicateS, sequenceS, untilS @@ -27,7 +29,8 @@ import Ideas.Common.Rewriting as Export 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, toLocation, fromLocation, arity, top) +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 qualified Ideas.Common.Strategy as S
src/Ideas/Common/Predicate.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- Representation for predicates -- ----------------------------------------------------------------------------- +-- $Id: Predicate.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Predicate ( -- * Predicate representation Predicate, predicate, predicateView @@ -59,7 +61,7 @@ changeId f a = f mempty :@ a instance Identify (Predicate a) where - n @> v | isEmptyId a = v + n @> v | a == mempty = v | otherwise = a :@ v where a = newId n
src/Ideas/Common/Rewriting.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Rewriting.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rewriting (module Export) where import Ideas.Common.Rewriting.RewriteRule as Export
src/Ideas/Common/Rewriting/AC.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: AC.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rewriting.AC ( -- * Types Pairings, PairingsList, PairingsPair
src/Ideas/Common/Rewriting/Confluence.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Confluence.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rewriting.Confluence ( isConfluent, checkConfluence, checkConfluenceWith , somewhereM
src/Ideas/Common/Rewriting/Difference.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- into account. -- ----------------------------------------------------------------------------- +-- $Id: Difference.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rewriting.Difference ( difference, differenceEqual , differenceWith, differenceEqualWith
src/Ideas/Common/Rewriting/RewriteRule.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: RewriteRule.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rewriting.RewriteRule ( -- * Supporting type class Different(..)
src/Ideas/Common/Rewriting/Substitution.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Substitutions on terms. Substitutions are idempotent, and non-cyclic. -- ----------------------------------------------------------------------------- +-- $Id: Substitution.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rewriting.Substitution ( Substitution, emptySubst, singletonSubst, dom, lookupVar , (@@), (|->), listToSubst, composable, (@+@) @@ -111,19 +113,20 @@ return (listToSubst (zip is ts)) tests :: TestSuite -tests = suite "Substitution" $ do - addProperty "left unit" $ \s -> - mempty @@ s == s - addProperty "right unit" $ \s -> - s @@ mempty == s - addProperty "associative" $ \s1 s2 s3 -> - composable s1 s2 && composable (s1 @@ s2) s3 - && composable s2 s3 && composable s1 (s2 @@ s3) - ==> (s1 @@ s2) @@ s3 == s1 @@ (s2 @@ s3) - addProperty "idempotence" $ \s -> - s @@ s == s - addProperty "idempotence/application" $ \s a -> - s |-> a == s |-> (s |-> a) - addProperty "composition" $ \s1 s2 a -> - composable s1 s2 - ==> s1 |-> (s2 |-> a) == (s1 @@ s2) |-> a+tests = suite "Substitution" + [ useProperty "left unit" $ \s -> + mempty @@ s == s + , useProperty "right unit" $ \s -> + s @@ mempty == s + , useProperty "associative" $ \s1 s2 s3 -> + composable s1 s2 && composable (s1 @@ s2) s3 + && composable s2 s3 && composable s1 (s2 @@ s3) + ==> (s1 @@ s2) @@ s3 == s1 @@ (s2 @@ s3) + , useProperty "idempotence" $ \s -> + s @@ s == s + , useProperty "idempotence/application" $ \s a -> + s |-> a == s |-> (s |-> a) + , useProperty "composition" $ \s1 s2 a -> + composable s1 s2 + ==> s1 |-> (s2 |-> a) == (s1 @@ s2) |-> a + ]
src/Ideas/Common/Rewriting/Term.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS -fno-warn-orphans #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,6 +13,8 @@ -- A simple data type for term rewriting -- ----------------------------------------------------------------------------- +-- $Id: Term.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rewriting.Term ( -- * Symbols Symbol, newSymbol
src/Ideas/Common/Rewriting/Unification.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Unification.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rewriting.Unification ( unify, match, matchExtended, matchList , Match, SymbolMatch @@ -168,22 +170,23 @@ --- * Test unification properties unificationTests :: TestSuite -unificationTests = suite "Unification" $ do - addProperty "unify" $ \a b -> - case unify a b of - Just s -> (s |-> a) == (s |-> b) - Nothing -> True - addProperty "unify-succeed" $ \a s -> - let b = s |-> a in - case unify a b of - Just s2 -> (s2 |-> a) == (s2 |-> b) - Nothing -> False - addProperty "match" $ \a b -> - case match a b of - Just s -> (s |-> a) == b - Nothing -> True - addProperty "match-succeed" $ \a s -> - let b = s |-> a in - case match a (s |-> a) of - Just s2 -> (s2 |-> a) == b - Nothing -> True+unificationTests = suite "Unification" + [ useProperty "unify" $ \a b -> + case unify a b of + Just s -> (s |-> a) == (s |-> b) + Nothing -> True + , useProperty "unify-succeed" $ \a s -> + let b = s |-> a in + case unify a b of + Just s2 -> (s2 |-> a) == (s2 |-> b) + Nothing -> False + , useProperty "match" $ \a b -> + case match a b of + Just s -> (s |-> a) == b + Nothing -> True + , useProperty "match-succeed" $ \a s -> + let b = s |-> a in + case match a (s |-> a) of + Just s2 -> (s2 |-> a) == b + Nothing -> True + ]
src/Ideas/Common/Rule.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Rule.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rule (module Export) where import Ideas.Common.Rule.Abstract as Export
src/Ideas/Common/Rule/Abstract.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,6 +14,8 @@ -- can be lifted with a view using the LiftView type class. -- ----------------------------------------------------------------------------- +-- $Id: Abstract.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rule.Abstract ( -- * Rule data type and accessors Rule, transformation, recognizer, checkReferences
src/Ideas/Common/Rule/EnvironmentMonad.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- State monad for environments -- ----------------------------------------------------------------------------- +-- $Id: EnvironmentMonad.hs 6542 2014-05-14 19:03:09Z bastiaan $ + module Ideas.Common.Rule.EnvironmentMonad ( -- * Environment Monad EnvMonad((:=), (:~), (:?)) @@ -22,7 +24,7 @@ , envMonadRefs, envMonadFunctionRefs ) where -import Control.Monad.State +import Control.Monad import Data.Maybe import Data.Typeable import Ideas.Common.Environment @@ -69,21 +71,20 @@ -- Environment Monad runEnvMonad :: EnvMonad a -> Environment -> [(a, Environment)] -runEnvMonad = runStateT . rec - where - rec :: EnvMonad a -> StateT Environment [] a - rec monad = - case monad of - Return a -> return a - Bind m f -> rec m >>= rec . f - Then m n -> rec m >> rec n - Fail s -> fail s - Zero -> mzero - Plus m n -> rec m `mplus` rec n - ref := a -> modify (insertRef ref a) - ref :~ f -> modify (changeRef ref f) - ref :? a -> gets (fromMaybe a . (ref ?)) - GetRef ref -> gets (ref ?) >>= maybe (fail "getRef") return +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
src/Ideas/Common/Rule/Parameter.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -15,6 +15,8 @@ -- the LiftView type class. -- ----------------------------------------------------------------------------- +-- $Id: Parameter.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rule.Parameter ( ParamTrans , supplyParameters, supplyContextParameters
src/Ideas/Common/Rule/Recognizer.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Recognizer.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rule.Recognizer ( -- * data type and type class Recognizable(..), Recognizer
src/Ideas/Common/Rule/Transformation.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, Rank2Types #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,6 +13,8 @@ -- a list of results (often a singleton list or the empty list). -- ----------------------------------------------------------------------------- +-- $Id: Transformation.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Rule.Transformation ( -- * Trans data type Transformation, Trans
src/Ideas/Common/Strategy.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -14,6 +14,8 @@ -- functions yourself. -- ----------------------------------------------------------------------------- +-- $Id: Strategy.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Strategy ( -- * Data types and type classes Strategy, LabeledStrategy @@ -29,6 +31,8 @@ -- ** Negation and greedy combinators , check, not, repeat, repeat1, try, (|>), exhaustive , while, until, multi + -- ** Graph + , DependencyGraph, dependencyGraph -- ** Traversal combinators , module Ideas.Common.Strategy.Traversal -- * Configuration combinators @@ -37,8 +41,8 @@ , strategyLocations, subStrategy , subTaskLocation, nextTaskLocation -- * Prefixes - , Prefix, emptyPrefix, makePrefix, prefixTree, Step(..) - , prefixToSteps, stepsToRules, lastStepInPrefix + , Prefix, showPrefix, emptyPrefix, makePrefix, prefixTree, Step(..), Path, emptyPath + , prefixToSteps, stepsToRules, lastStepInPrefix, activeLabels -- * Misc , cleanUpStrategy, cleanUpStrategyAfter , rulesInStrategy @@ -49,6 +53,7 @@ import Ideas.Common.Strategy.Configuration import Ideas.Common.Strategy.Location import Ideas.Common.Strategy.Parsing +import Ideas.Common.Strategy.Path import Ideas.Common.Strategy.Prefix import Ideas.Common.Strategy.Traversal hiding (full, spine, stop, once) import Prelude ()
src/Ideas/Common/Strategy/Abstract.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Abstract.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Strategy.Abstract ( Strategy, IsStrategy(..) , LabeledStrategy, label, unlabel @@ -142,7 +144,10 @@ instance IsLabeled RewriteRule where toLabeled = toLabeled . ruleRewrite --- | Labels a strategy with a string +-- | Labels a strategy with an identifier. Labels are used to identify +-- substrategies and to specialize feedback messages. The first argument of +-- 'label' can be of type 'String', in which case the string is used as +-- identifier (and not as description). label :: (IsId l, IsStrategy f) => l -> f a -> LabeledStrategy a label l = LS (makeInfo l) . toStrategy @@ -158,7 +163,8 @@ where rec env core = case core of - Rec n a -> Rec n (rec ((n, core):env) a) + -- Rec n a -> Rec n (rec ((n, core):env) a) + -- Let ?? Label l a -> forLabel env l (rec env a) _ -> descend (rec env) core @@ -178,14 +184,14 @@ -- | Returns the derivation tree for a strategy and a term, including all -- minor rules -fullDerivationTree :: IsStrategy f => Bool -> f a -> a -> DerivationTree (Step LabelInfo a) a -fullDerivationTree search = make . processLabelInfo id . toCore . toStrategy +fullDerivationTree :: IsStrategy f => f a -> a -> DerivationTree (Step LabelInfo a) a +fullDerivationTree = make . processLabelInfo id . toCore . toStrategy where - make core = fmap value . parseDerivationTree search . makeState core + make core a = fmap fst (parseDerivationTree a (makeState a core)) -- | Returns the derivation tree for a strategy and a term with only major rules -derivationTree :: IsStrategy f => Bool -> f a -> a -> DerivationTree (Rule a, Environment) a -derivationTree search s = mergeMaybeSteps . mapFirst f . fullDerivationTree search s +derivationTree :: IsStrategy f => f a -> a -> DerivationTree (Rule a, Environment) a +derivationTree s = mergeMaybeSteps . mapFirst f . fullDerivationTree s where f (RuleStep env r) | isMajor r = Just (r, env) f _ = Nothing @@ -215,7 +221,7 @@ cleanUpStrategy :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a cleanUpStrategy f (LS n s) = cleanUpStrategyAfter f (LS n (make s)) where - make = liftCore2 (.*.) (doAfter f (idRule ())) + make = liftCore2 (:*:) (doAfter f (idRule ())) -- | Use a function as do-after hook for all rules in a labeled strategy cleanUpStrategyAfter :: (a -> a) -> LabeledStrategy a -> LabeledStrategy a @@ -226,7 +232,6 @@ noInterleaving = liftCore $ transform f where f (a :%: b) = a :*: b - f (a :!%: b) = a :*: b f (Atomic a) = a f s = s
src/Ideas/Common/Strategy/Combinators.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,13 +12,20 @@ -- data types -- ----------------------------------------------------------------------------- +-- $Id: Combinators.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Strategy.Combinators where +import Data.Array +import Data.Graph +import Data.List ((\\)) +import Ideas.Common.Classes import Ideas.Common.Id import Ideas.Common.Rule import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Configuration import Ideas.Common.Strategy.Core +import Ideas.Common.Utils (fst3) import Prelude hiding (not, repeat, fail, sequence) import qualified Prelude @@ -27,23 +34,27 @@ -- Basic combinators -------------------------------------- -infixr 2 <%> +infixr 2 <%>, <@> infixr 3 <|> infixr 4 |> infixr 5 <*> -- | Put two strategies in sequence (first do this, then do that) (<*>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -(<*>) = liftCore2 (.*.) +(<*>) = liftCore2 (:*:) -- | Choose between the two strategies (either do this or do that) (<|>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -(<|>) = liftCore2 (.|.) +(<|>) = liftCore2 (:|:) -- | Interleave two strategies (<%>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a -(<%>) = liftCore2 (.%.) +(<%>) = liftCore2 (:%:) +-- | Alternate two strategies +(<@>) :: (IsStrategy f, IsStrategy g) => f a -> g a -> Strategy a +(<@>) = liftCore2 (:@:) + -- | The strategy that always succeeds (without doing anything) succeed :: Strategy a succeed = fromCore Succeed @@ -76,7 +87,7 @@ -- | Repeat a strategy zero or more times (non-greedy) many :: IsStrategy f => f a -> Strategy a -many = liftCore Many +many a = fix $ \x -> succeed <|> (a <*> x) -- | Apply a certain strategy at least once (non-greedy) many1 :: IsStrategy f => f a -> Strategy a @@ -100,11 +111,13 @@ -- | Check whether or not the argument strategy cannot be applied: the result -- strategy only succeeds if this is not the case (otherwise it fails). not :: IsStrategy f => f a -> Strategy a -not = liftCore (Not . noLabels) +not s = check (Prelude.not . applicable (toStrategy s)) +-- liftCore (Not . noLabels) + -- | Repeat a strategy zero or more times (greedy version of 'many') repeat :: IsStrategy f => f a -> Strategy a -repeat = liftCore Repeat +repeat a = fix $ \x -> (a <*> x) |> succeed -- | Apply a certain strategy at least once (greedy version of 'many1') repeat1 :: IsStrategy f => f a -> Strategy a @@ -138,4 +151,21 @@ -- | A fix-point combinator on strategies (to model recursion). Powerful -- (but dangerous) combinator fix :: (Strategy a -> Strategy a) -> Strategy a -fix f = fromCore (coreFix (toCore . f . fromCore))+fix f = fromCore (coreFix (toCore . f . fromCore)) + +-- Graph to strategy ---------------------- + +type DependencyGraph node key = (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex) + +-- | Create a strategy from a dependency graph with strategies as nodes +-- Does not check for cycles +dependencyGraph:: IsStrategy f => DependencyGraph (f a) key -> Strategy a +dependencyGraph (graph, vertex2data, _) = g2s [] + where + g2s seen + | null reachables = succeed + | otherwise = alternatives $ map makePath reachables + where + reachables = filter isReachable $ vertices graph \\ seen + isReachable = null . (\\ seen) . (graph!) + makePath vertex = (fst3 . vertex2data) vertex <*> g2s (vertex:seen)
src/Ideas/Common/Strategy/Configuration.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Configuration.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Strategy.Configuration ( -- Types and constructors StrategyConfiguration, makeStrategyConfiguration
src/Ideas/Common/Strategy/Core.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,32 +13,35 @@ -- directly on it. -- ----------------------------------------------------------------------------- +-- $Id: Core.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Strategy.Core ( GCore(..), Core - , (.|.), (.*.), (.%.) - , coreMany, coreRepeat, coreOrElse, coreFix + , coreFix, coreSubstAll , noLabels, substCoreVar ) where -import Control.Applicative +import Data.Maybe import Ideas.Common.Classes import Ideas.Common.Rule +import Ideas.Common.Strategy.Sequential import Ideas.Common.Utils.QuickCheck import Ideas.Common.Utils.Uniplate -import qualified Data.Foldable as F -import qualified Data.Traversable as T ----------------------------------------------------------------- -- Strategy (internal) data structure, containing a selection -- of combinators -infixr 2 :%:, :!%:, .%. -infixr 3 :|:, :|>:, .|. -infixr 5 :*:, .*. +infixr 2 :%:, :@: +infixr 3 :|:, :|>: +infixr 5 :*: -- | Core expression, with rules type Core l a = GCore l (Rule a) +-- | An environment with generalized Core expressions +type CoreEnv l a = [(Int, GCore l a)] + -- | A generalized Core expression, not restricted to rules. This makes GCore -- a (traversable and foldable) functor. data GCore l a @@ -46,19 +49,24 @@ | GCore l a :|: GCore l a | GCore l a :|>: GCore l a | GCore l a :%: GCore l a -- interleave - | GCore l a :!%: GCore l a -- interleave-first-from-left - | Many (GCore l a) - | Repeat (GCore l a) - | Not (GCore l a) + | GCore l a :@: GCore l a -- alternate | Label l (GCore l a) | Atomic (GCore l a) | Succeed | Fail | Rule a -- ^ Generalized constructor (not restricted to rules) | Var Int - | Rec Int (GCore l a) + | Let (CoreEnv l a) (GCore l a) deriving Show +instance Sequential (GCore l) where + ok = Succeed + stop = Fail + single = Rule + (<|>) = (:|:) + (<?>) = (:|>:) + (<*>) = (:*:) + ----------------------------------------------------------------- -- Useful instances @@ -72,13 +80,12 @@ a :|: b -> plate (:|:) |* a |* b a :|>: b -> plate (:|>:) |* a |* b a :%: b -> plate (:%:) |* a |* b - a :!%: b -> plate (:!%:) |* a |* b - Many a -> plate Many |* a - Repeat a -> plate Repeat |* a + a :@: b -> plate (:@:) |* a |* b Label l a -> plate Label |- l |* a Atomic a -> plate Atomic |* a - Rec n a -> plate Rec |- n |* a - Not a -> plate Not |* a + Let ds a -> let (ns, bs) = unzip ds + make = Let . zip ns + in plate make ||* bs |* a _ -> plate core instance BiFunctor GCore where @@ -90,40 +97,15 @@ a :|: b -> rec a :|: rec b a :|>: b -> rec a :|>: rec b a :%: b -> rec a :%: rec b - a :!%: b -> rec a :!%: rec b - Many a -> Many (rec a) - Repeat a -> Repeat (rec a) - Not a -> Not (rec a) + a :@: b -> rec a :@: rec b Atomic a -> Atomic (rec a) - Rec n a -> Rec n (rec a) + Let ds a -> Let (map (mapSecond rec) ds) (rec a) Label l a -> Label (f l) (rec a) Rule a -> Rule (g a) Var n -> Var n Succeed -> Succeed Fail -> Fail -instance T.Traversable (GCore l) where - traverse f core = - case core of - a :*: b -> (:*:) <$> T.traverse f a <*> T.traverse f b - a :|: b -> (:|:) <$> T.traverse f a <*> T.traverse f b - a :|>: b -> (:|>:) <$> T.traverse f a <*> T.traverse f b - a :%: b -> (:%:) <$> T.traverse f a <*> T.traverse f b - a :!%: b -> (:!%:) <$> T.traverse f a <*> T.traverse f b - Many a -> Many <$> T.traverse f a - Repeat a -> Repeat <$> T.traverse f a - Label l a -> Label l <$> T.traverse f a - Atomic a -> Atomic <$> T.traverse f a - Rec n a -> Rec n <$> T.traverse f a - Not a -> Not <$> T.traverse f a - Rule r -> Rule <$> f r - Succeed -> pure Succeed - Fail -> pure Fail - Var n -> pure $ Var n - -instance F.Foldable (GCore l) where - foldMap = T.foldMapDefault - instance (Arbitrary l, Arbitrary a) => Arbitrary (GCore l a) where arbitrary = generators [ constGens [Succeed, Fail] @@ -132,54 +114,33 @@ ] ----------------------------------------------------------------- --- Smart constructors - -(.|.) :: GCore l a -> GCore l a -> GCore l a -Fail .|. b = b -a .|. Fail = a -a .|. b = a :|: b - -(.*.) :: GCore l a -> GCore l a -> GCore l a -Fail .*. _ = Fail -Succeed .*. b = b -_ .*. Fail = Fail -a .*. Succeed = a -a .*. b = a :*: b - -(.%.) :: GCore l a -> GCore l a -> GCore l a -Fail .%. _ = Fail -Succeed .%. b = b -_ .%. Fail = Fail -a .%. Succeed = a -a .%. b = a :%: b - ------------------------------------------------------------------ -- Definitions -coreMany :: GCore l a -> GCore l a -coreMany a = Rec n (Succeed :|: (a :*: Var n)) - where n = nextVar a - -coreRepeat :: GCore l a -> GCore l a -coreRepeat a = Many a :*: Not a - -coreOrElse :: GCore l a -> GCore l a -> GCore l a -coreOrElse a b = a :|: (Not a :*: b) - coreFix :: (GCore l a -> GCore l a) -> GCore l a coreFix f = -- disadvantage: function f is applied twice let i = nextVar (f (Var (-1))) - in Rec i (f (Var i)) + in coreRec i (f (Var i)) +coreRec :: Int -> GCore l a -> GCore l a +coreRec n a = Let [(n, a)] (Var n) + +coreSubstAll :: GCore l a -> GCore l a +coreSubstAll = rec [] + where + rec xs (Var i) = fromMaybe (error "coreInf") (lookup i xs) + rec xs (Let ds a) = let this = [ (n, rec this b) | (n, b) <- ds ] ++ xs + in rec this a + rec xs core = descend (rec xs) core + ----------------------------------------------------------------- -- Utility functions substCoreVar :: Int -> GCore l a -> GCore l a -> GCore l a substCoreVar i a core = case core of - Var j | i==j -> a - Rec j _ | i==j -> core - _ -> descend (substCoreVar i a) core + Var j | i==j -> a + Let ds _ | i `elem` map fst ds -> core + _ -> descend (substCoreVar i a) core nextVar :: GCore l a -> Int nextVar p @@ -190,9 +151,10 @@ coreVars :: GCore l a -> [Int] coreVars core = case core of - Var n -> [n] - Rec n a -> n : coreVars a - _ -> concatMap coreVars (children core) + Var n -> [n] + Let ds a -> let (ns, bs) = unzip ds + in ns ++ concatMap coreVars (bs ++ [a]) + _ -> concatMap coreVars (children core) noLabels :: GCore l a -> GCore l a noLabels (Label _ a) = noLabels a
src/Ideas/Common/Strategy/Location.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Locations in a strategy -- ----------------------------------------------------------------------------- +-- $Id: Location.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Strategy.Location ( subTaskLocation, nextTaskLocation , strategyLocations, subStrategy @@ -62,7 +64,6 @@ collect core = case core of Label l t -> [(l, t)] - Not _ -> [] _ -> concatMap collect (children core) -- | Returns the substrategy or rule at a strategy location. Nothing
src/Ideas/Common/Strategy/Parsing.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,31 +11,39 @@ -- Basic machinery for executing a core strategy expression. -- ----------------------------------------------------------------------------- +-- $Id: Parsing.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Strategy.Parsing ( Step(..) - , State, makeState, stack, choices, trace, value - , parseDerivationTree, replay, runCore - , firsts, Result(..), isReady + , ParseState, makeState, choices, trace + , parseDerivationTree, replay, runCore, searchModeState, toProcess ) where -import Control.Arrow -import Control.Monad +import Data.Function (on) import Data.Monoid import Ideas.Common.Classes import Ideas.Common.DerivationTree import Ideas.Common.Environment import Ideas.Common.Rule import Ideas.Common.Strategy.Core -import Ideas.Common.Utils.Uniplate +import Ideas.Common.Strategy.Path +import Ideas.Common.Strategy.Sequential hiding (replay) +import Ideas.Common.Utils (fst3) +import qualified Ideas.Common.Strategy.Sequential as Sequential ---------------------------------------------------------------------- -- Step data type data Step l a = Enter l | Exit l | RuleStep Environment (Rule a) - deriving (Show, Eq) + deriving (Eq) +instance Show (Step l a) where + show (Enter _) = "Enter" + show (Exit _) = "Exit" + show (RuleStep _ r) = show r + -- A core expression where the symbols are steps instead of "only" rules -type StepCore l a = GCore l (Step l a) +-- type StepCore l a = GCore l (Step l a) instance Apply (Step l) where applyAll (RuleStep _ r) = applyAll r @@ -51,255 +59,96 @@ ---------------------------------------------------------------------- -- State data type -data State l a = S - { stack :: Stack l a - , choices :: [Bool] - , trace :: [Step l a] - , timeout :: !Int - , value :: a - } deriving Show - -data Stack l a = Stack - { active :: [StepCore l a] -- the active items, performed in sequence - , suspended :: [StepCore l a] -- suspended items, performed after a step from active - , remainder :: [StepCore l a] -- remaining items: must be empty if there are no suspended items - } deriving Show - -makeState :: Core l a -> a -> State l a -makeState = newState . fmap (RuleStep mempty) +data ParseState l a = S + { trace :: [Step l a] + , choices :: Path + , remainder :: Process (Step l a, a, Path) + } -newState :: StepCore l a -> a -> State l a -newState core a = push core (S emptyStack [] [] 0 a) +makeState :: a -> Core l a -> ParseState l a +makeState a = S [] emptyPath . applyMin a . withPath . toProcess ---------------------------------------------------------------------- -- Parse derivation tree -parseDerivationTree :: Bool -> State l a -> DerivationTree (Step l a) (State l a) -parseDerivationTree search - | search = mapSecond (changeStack removeRecAnnotations) . tree - | otherwise = tree - where - tree = makeTree $ \state -> - let xs = firsts search state - in ( any (isReady . fst) xs , [ (step, s) | (Result step, s) <- xs ] ) - - removeRecAnnotations (Stack as ss rs) = - Stack (map f as) (map f ss) (map f rs) - where - f (Rec (-666) Fail) = Succeed - f core = descend f core - -firsts :: Bool -> State l a -> [(Result (Step l a), State l a)] -firsts search st = - case pop st of - Nothing -> [(Ready, st)] - Just (core, s) -> firstsStep core s +parseDerivationTree :: a -> ParseState l a -> DerivationTree (Step l a) (a, ParseState l a) +parseDerivationTree = curry (makeTree next) where - firstsStep core state = - case core of - a :*: b -> firstsStep a (push b state) - a :|: b -> chooseFor True a ++ chooseFor False b - a :%: b -> firstsStep (coreInterleave search a b) state - a :!%: b -> firstsStep a (suspend b state) - Rec i a -> incrTimer state >>= firstsStep (substCoreVar i core a) - Var _ -> freeCoreVar "firsts" - Rule r -> hasStep r - Label l a -> firstsStep (coreLabel l a) state - Atomic a -> firstsStep a (useAtomic state) - Not a -> guard (checkNot a state) >> firsts search state - a :|>: b -> firstsStep (coreOrElse a b) state - Many a -> firstsStep (coreMany a) state - Repeat a -> firstsStep (coreRepeat a) state - Fail -> [] - Succeed -> firsts search state - where - chooseFor b = flip firstsStep (makeChoice b state) - hasStep step = [ (Result (head (trace s)), s) | s <- useRule step state ] - -- hasStep step = [ (Result step, s) | s <- useRule step (traceStep step state) ] - --- helper datatype -data Result a = Result a | Ready deriving Show + next (_, st) = (empty (remainder st), stateFirsts st (remainder st)) -instance Functor Result where - fmap f (Result a) = Result (f a) - fmap _ Ready = Ready + stateFirsts st p = + [ ( step + , (a, st {trace = step:trace st, remainder = q, choices = path}) + ) + | ((step, a, path), q) <- Sequential.firsts p + ] -isReady :: Result a -> Bool -isReady Ready = True -isReady _ = False +searchModeState :: (Step l a -> Bool) -> (Step l a -> Step l a -> Bool) -> ParseState l a -> ParseState l a +searchModeState p eq state = + state { remainder = tidyProcess eq' (not . p') $ + uniquePath p' eq' (remainder state) } + where + eq' = eq `on` fst3 + p' = p . fst3 ---------------------------------------------------------------------- -- Running the parser runCore :: Core l a -> a -> [a] -runCore core = runState . makeState core - -runState :: State l a -> [a] -runState st = - case pop st of - Nothing -> [value st] - Just (core, s) -> runStep core s - where - runStep core state = - case core of - a :*: b -> runStep a (push b state) - a :|: b -> runStep a state ++ runStep b state - a :%: b -> runStep (coreInterleave False a b) state - a :!%: b -> runStep a (suspend b state) - Rec i a -> incrTimer state >>= runStep (substCoreVar i core a) - Var _ -> freeCoreVar "runState" - Rule r -> concatMap runState (useRule r (interleave r state)) - Label _ a -> runStep a state - Atomic a -> runStep a (useAtomic state) - Not a -> guard (checkNot a state) >> runState state - a :|>: b -> let xs = runStep a state - in if null xs then runStep b state else xs - Many a -> runStep (coreMany a) state - Repeat a -> runStep (coreRepeat a) state - Fail -> [] - Succeed -> runState state - ----------------------------------------------------------------------- --- Replay a parse run - -replay :: Monad m => Int -> [Bool] -> Core l a -> m (State l a) -replay n0 bs0 = replayState n0 bs0 . flip makeState noValue +runCore = runProcess . toProcess . noLabels where - noValue = error "no value in replay" - - replayState n bs state = - case pop state of - _ | n==0 -> return state - Nothing -> return state - Just (core, s) -> replayStep n bs core s - - replayStep n bs core state = - case core of - _ | n==0 -> return state - a :*: b -> replayStep n bs a (push b state) - a :|: b -> case bs of - [] -> fail "replay failed" - x:xs -> let new = if x then a else b - in replayStep n xs new (makeChoice x state) - a :%: b -> replayStep n bs (coreInterleave False a b) state - a :!%: b -> replayStep n bs a (suspend b state) - Rec i a -> replayStep n bs (substCoreVar i core a) state - Var _ -> freeCoreVar "replay" - Rule r -> replayState (n-1) bs (traceStep r state) - Label l a -> replayStep n bs (coreLabel l a) state - Atomic a -> replayStep n bs a (useAtomic state) - Not _ -> replayState n bs state - a :|>: b -> replayStep n bs (coreOrElse a b) state - Many a -> replayStep n bs (coreMany a) state - Repeat a -> replayStep n bs (coreRepeat a) state - Fail -> fail "replay failed" - Succeed -> replayState n bs state + runProcess p a = rec a (applyMin2 a p) ----------------------------------------------------------------------- --- Core translations + rec a p = + (if empty p then (a:) else id) + [ c + | ((_, b), q) <- firsts p + , c <- rec b q + ] -coreLabel :: l -> StepCore l a -> StepCore l a -coreLabel l a = Rule (Enter l) :*: a :*: Rule (Exit l) +----------------------------- -coreInterleave :: Bool -> StepCore l a -> StepCore l a -> StepCore l a -coreInterleave search a b = (a :!%: b) :|: (b :!%: a') :|: emptyOnly (a :*: b) - where - a' = if search then Rec (-666) Fail :*: a else a - emptyOnly core = +toProcess :: Core l a -> Process (Step l a) +toProcess = fromAtoms . build . rec . coreSubstAll + where + rec core = case core of - Rec (-666) Fail :*: y -> emptyOnly y - Rule step | interleaveAfter step -> Fail - Not _ -> core - x :|>: y -> emptyOnly x .|. (Not x :*: emptyOnly y) - Repeat x -> emptyOnly (coreRepeat x) - x :|: y -> emptyOnly x .|. emptyOnly y - x :*: y -> emptyOnly x .*. emptyOnly y - x :%: y -> emptyOnly x .*. emptyOnly y -- no more interleaving - x :!%: y -> emptyOnly x .*. emptyOnly y -- no more interleaving - _ -> descend emptyOnly core - ----------------------------------------------------------------------- --- State functions - -push :: StepCore l a -> State l a -> State l a -push = changeStack . pushStack - -suspend :: StepCore l a -> State l a -> State l a -suspend = changeStack . suspendStack - -useAtomic :: State l a -> State l a -useAtomic = changeStack interleaveStack - -pop :: State l a -> Maybe (StepCore l a, State l a) -pop s = fmap (second f) (popStack (stack s)) - where f new = s {stack = new} - -makeChoice :: Bool -> State l a -> State l a -makeChoice b s = s {choices = b : choices s} - -checkNot :: StepCore l a -> State l a -> Bool -checkNot core = null . runState . newState core . value - -useRule :: Step l a -> State l a -> [State l a] -useRule step state = map resetTimer $ - case step of - RuleStep _ r -> do - (a, env) <- transApply (transformation r) (value state) - return $ traceStep (RuleStep env r) state {value = a} - _ -> [traceStep step state] - -traceStep :: Step l a -> State l a -> State l a -traceStep step s = interleave step s {trace = step : trace s} - -freeCoreVar :: String -> a -freeCoreVar caller = error $ "Free var in core expression: " ++ caller - -incrTimer :: Monad m => State l a -> m (State l a) -incrTimer s - | timeout s >= 20 = fail "timeout after 20 fixpoints" - | otherwise = return (s {timeout = timeout s + 1}) - -resetTimer :: State l a -> State l a -resetTimer s = s {timeout = 0} - -interleaveAfter :: Step l a -> Bool -interleaveAfter (RuleStep _ _) = True -interleaveAfter _ = False - -interleave :: Step l a -> State l a -> State l a -interleave step = if interleaveAfter step then useAtomic else id - -changeStack :: (Stack l a -> Stack l a) -> State l a -> State l a -changeStack f s = s {stack = f (stack s)} - ----------------------------------------------------------------------- --- Stack functions - -emptyStack :: Stack l a -emptyStack = Stack [] [] [] - -pushStack :: StepCore l a -> Stack l a -> Stack l a -pushStack core s = s {active = core : active s} - -suspendStack :: StepCore l a -> Stack l a -> Stack l a -suspendStack core s - | null (active s) = s {suspended = core : suspended s} - | otherwise = emptyStack {suspended = [core], remainder = combineStack s} + a :*: b -> rec a <*> rec b + a :|: b -> rec a <|> rec b + Rule r -> single (Single (RuleStep mempty r)) + a :|>: b -> rec a <?> rec b + Fail -> stop + Succeed -> ok + Label l a -> Single (Enter l) ~> rec a + <*> single (Single (Exit l)) + a :%: b -> concurrent switch (build (rec a)) (build (rec b)) + a :@: b -> build (rec a) <@> build (rec b) + Atomic a -> atomic (build (rec a)) + Let _ _ -> error "toMin: let" + Var _ -> error "toMin: var" -popStack :: Stack l a -> Maybe (StepCore l a, Stack l a) -popStack s = - case active s of - x:xs -> Just (x, s {active = xs}) - [] | null (suspended s) -> Nothing - | otherwise -> Just (Fail, s) + switch (Single (Enter _)) = False + switch _ = True -interleaveStack :: Stack l a -> Stack l a -interleaveStack s = emptyStack {active = combineStack s} +applyMin2 :: a -> Process (Step l a) -> Process (Step l a, a) +applyMin2 a0 = prune (isMajor . fst) . scanChoice step a0 + where + step a (RuleStep _ r) = + [ (b, (RuleStep env r, b)) + | (b, env) <- transApply (transformation r) a + ] + step a st = [(a, (st, a))] -combineStack :: Stack l a -> [StepCore l a] -combineStack s - | null (suspended s) = active s - | otherwise = front : remainder s +applyMin :: a -> Process (Step l a, Path) -> Process (Step l a, a, Path) +applyMin a0 = prune (isMajor . fst3) . scanChoice step a0 where - actives = foldr (.*.) Succeed (active s) - front = foldr (.%.) Succeed (actives:suspended s)+ step a (RuleStep _ r, bs) = + [ (b, (RuleStep env r, b, bs)) + | (b, env) <- transApply (transformation r) a + ] + step a (st, bs) = [(a, (st, a, bs))] + +replay :: Monad m => Path -> a -> Core l a -> m (ParseState l a) +replay path a core = do + (as, p) <- Sequential.replay path $ withPath $ toProcess core + return (S (map fst as) path (applyMin a p))
+ src/Ideas/Common/Strategy/Path.hs view
@@ -0,0 +1,70 @@+----------------------------------------------------------------------------- +-- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +-- A path encodes a location (sub-part) of a strategy by: +-- * maintaining a list of directions (go left/go right) for each choice; +-- * the depth (number of steps) +-- Use Show/Read type classes for serialization/deserialization +-- +----------------------------------------------------------------------------- +-- $Id: Path.hs 6535 2014-05-14 11:05:06Z bastiaan $ + +module Ideas.Common.Strategy.Path + ( -- * datatype and constructor + Path, emptyPath + -- * extending a path + , toLeft, toRight, tick + -- * following a path + , leftOrRight, untick + ) where + +import Data.Foldable (toList) +import Data.Sequence (Seq, empty, (|>), viewl, ViewL(..), fromList) +import Ideas.Common.Classes + +data Path = Path !Int (Seq Bool) -- depth, choices + deriving Eq + +instance Show Path where + show = show . intList + +instance Read Path where + readsPrec _ = map (mapFirst fromIntList) . readList + +emptyPath :: Path +emptyPath = Path 0 empty + +toLeft, toRight, tick :: Path -> Path +toLeft (Path n bs) = Path (n+1) (bs |> True) +toRight (Path n bs) = Path (n+1) (bs |> False) +tick (Path n bs) = Path (n+1) bs + +-- |Following a path without going left or right (counterpart of 'tick') +untick :: Monad m => Path -> m Path +untick (Path n bs) + | n > 0 = return (Path (n-1) bs) + | otherwise = fail "untick: invalid path" + +leftOrRight :: Monad m => Path -> m (Either Path Path) +leftOrRight (Path n bs) = + case viewl bs of + b :< cs | n > 0 && b -> return (Left (Path (n-1) cs)) + | n > 0 -> return (Right (Path (n-1) cs)) + _ -> fail "untick: invalid path" + +-- local helpers +intList :: Path -> [Int] +intList (Path n bs) + | n == 0 = [] + | otherwise = n : map (\b -> if b then 0 else 1) (toList bs) + +fromIntList :: [Int] -> Path +fromIntList [] = emptyPath +fromIntList (n:is) = Path n (fromList (map (==0) is))
src/Ideas/Common/Strategy/Prefix.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,18 +12,21 @@ -- and allows to continue the derivation at that particular point. -- ----------------------------------------------------------------------------- +-- $Id: Prefix.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Strategy.Prefix - ( Prefix, emptyPrefix, makePrefix + ( Prefix, emptyPrefix, makePrefix, showPrefix , prefixToSteps, prefixTree, stepsToRules, lastStepInPrefix, activeLabels + , searchModePrefix ) where -import Control.Monad import Data.List import Data.Maybe import Ideas.Common.DerivationTree import Ideas.Common.Rule import Ideas.Common.Strategy.Abstract import Ideas.Common.Strategy.Parsing +import Ideas.Common.Strategy.Path ----------------------------------------------------------- --- Prefixes @@ -32,42 +35,30 @@ -- executed rules). A prefix is still "aware" of the labels that appear in the -- strategy. A prefix is encoded as a list of integers (and can be reconstructed -- from such a list: see @makePrefix@). The list is stored in reversed order. -data Prefix a = P (State LabelInfo a) - -prefixPair :: Prefix a -> (Int, [Bool]) -prefixPair (P s) = (length (trace s), reverse (choices s)) - -prefixIntList :: Prefix a -> [Int] -prefixIntList = f . prefixPair - where - f (0, []) = [] - f (n, bs) = n : map (\b -> if b then 0 else 1) bs - -instance Show (Prefix a) where - show = show . prefixIntList +type Prefix = ParseState LabelInfo -instance Eq (Prefix a) where - a == b = prefixPair a == prefixPair b +showPrefix :: Prefix a -> String +showPrefix = show . choices -- | Construct the empty prefix for a labeled strategy -emptyPrefix :: LabeledStrategy a -> Prefix a -emptyPrefix = fromMaybe (error "emptyPrefix") . makePrefix [] +emptyPrefix :: LabeledStrategy a -> a -> Prefix a +emptyPrefix a = fromMaybe (error "emptyPrefix") . makePrefix emptyPath a -- | Construct a prefix for a given list of integers and a labeled strategy. -makePrefix :: Monad m => [Int] -> LabeledStrategy a -> m (Prefix a) -makePrefix [] ls = makePrefix [0] ls -makePrefix (i:is) ls = liftM P $ - replay i (map (==0) is) (mkCore ls) +makePrefix :: Monad m => Path -> LabeledStrategy a -> a -> m (Prefix a) +makePrefix path = flip (replay path) . mkCore where mkCore = processLabelInfo id . toCore . toStrategy -- | Create a derivation tree with a "prefix" as annotation. -prefixTree :: Bool -> Prefix a -> a -> DerivationTree (Prefix a) a -prefixTree search (P s) a = fmap value $ updateAnnotations (\_ _ -> P) $ - parseDerivationTree search s {value = a} +prefixTree :: a -> Prefix a -> DerivationTree (Prefix a) a +prefixTree a = fmap fst . updateAnnotations (\_ _ -> snd) . parseDerivationTree a +searchModePrefix :: (Step LabelInfo a -> Bool) -> (Step LabelInfo a -> Step LabelInfo a -> Bool) -> Prefix a -> Prefix a +searchModePrefix = searchModeState + prefixToSteps :: Prefix a -> [Step LabelInfo a] -prefixToSteps (P t) = reverse (trace t) +prefixToSteps = reverse . trace -- | Retrieves the rules from a list of steps stepsToRules :: [Step l a] -> [Rule a] @@ -75,7 +66,7 @@ -- | Returns the last rule of a prefix (if such a rule exists) lastStepInPrefix :: Prefix a -> Maybe (Step LabelInfo a) -lastStepInPrefix (P t) = listToMaybe (trace t) +lastStepInPrefix = listToMaybe . trace -- | Calculate the active labels activeLabels :: Prefix a -> [LabelInfo]
+ src/Ideas/Common/Strategy/Sequential.hs view
@@ -0,0 +1,326 @@+----------------------------------------------------------------------------- +-- Copyright 2014, Open Universiteit Nederland. This file is distributed +-- under the terms of the GNU General Public License. For more information, +-- see the file "LICENSE.txt", which is included in the distribution. +----------------------------------------------------------------------------- +-- | +-- Maintainer : bastiaan.heeren@ou.nl +-- Stability : provisional +-- Portability : portable (depends on ghc) +-- +----------------------------------------------------------------------------- +-- $Id: Sequential.hs 6535 2014-05-14 11:05:06Z bastiaan $ + +module Ideas.Common.Strategy.Sequential + ( Sequential(..) + , Process + , Builder, build + , empty, firsts, scanChoice, prune + , fromAtoms + , Sym(..) + , atomic, concurrent, (<@>) + , withPath, replay + , uniquePath, tidyProcess + ) where + +import Ideas.Common.Strategy.Path + +class Sequential f where + ok, stop :: f a + single :: a -> f a + (~>) :: a -> f a -> f a + (<|>) :: f a -> f a -> f a + (<?>) :: f a -> f a -> f a + (<*>) :: f a -> f a -> f a + choice :: [f a] -> f a + -- default implementation + single a = a ~> ok + a ~> p = single a <*> p + p <?> q = p <|> q -- angelic by default + choice = foldr (<|>) stop + +infixr 3 :~>, ~> + +data Process a + = Process a :|: Process a -- choice (p or q) + | Process a :?: Process a -- non-deterministic choice (behaves as either p or q) + | a :~> Process a -- prefix (a then p) + | Ok -- successful termination + | Stop -- failure + deriving (Show, Eq) + +instance Sequential Process where + ok = Ok + stop = Stop + (~>) = (:~>) + (<?>) = (:?:) + (<|>) = (:|:) + + p <*> Ok = p + p <*> q = fold (Alg (<|>) (:?:) (:~>) q Stop) p + +newtype Builder a = B (Process a -> Process a) + +instance Sequential Builder where + ok = B id + stop = B (const Stop) + single a = B (a ~>) + a ~> B f = B ((a ~>) . f) + + B f <|> B g = B (\p -> f p <|> g p) + B f <?> B g = B (\p -> f p <?> g p) + B f <*> B g = B (f . g) + +build :: Builder a -> Process a +build (B f) = f Ok + +{- +data Menu a = Menu { empty :: Bool, firstsSeq :: S.Seq (a, Menu a) } + +firsts :: Menu a -> [(a, Menu a)] +firsts = toList . firstsSeq + +instance Sequential Menu where + ok = Menu True S.empty + stop = Menu False S.empty + a ~> m = Menu False (S.singleton (a, m)) + + Menu b1 xs <|> Menu b2 ys = Menu (b1 || b2) (xs <> ys) + + Menu b xs <*> m + | b = m <|> ys + | otherwise = ys + where + ys = Menu b $ fmap (\(a, p) -> (a, p <*> m)) xs -} + +data Alg a b = Alg + { forChoice :: b -> b -> b + , forEither :: b -> b -> b + , forPrefix :: a -> b -> b + , forOk :: b + , forStop :: b + } + +{- +instance Monoid (Process a) where + mempty = stop + mappend = (<|>) -} + +--instance Functor Process where +-- fmap f = fold (Alg (:|:) (:?:) ((:~>) . f) Ok Stop) + +{- +instance Monad Process where + return = (:~> ok) + fail _ = Stop + p >>= f = fold (Alg (:|:) (:?:) ((<*>) . f) Ok Stop) p -} + +fold :: Alg a b -> Process a -> b +fold alg = rec + where + rec (p :|: q) = forChoice alg (rec p) (rec q) + rec (p :?: q) = forEither alg (rec p) (rec q) + rec (a :~> p) = forPrefix alg a (rec p) + rec Ok = forOk alg + rec Stop = forStop alg + + {- +join :: Process (Process a) -> Process a +join = fold (Alg (:|:) (:?:) (<*>) Ok Stop) +-} + +-- angelic for non-deterministic choice +empty :: Process a -> Bool +empty = fold $ Alg (||) (||) (\_ _ -> False) True False + +-- angelic for non-deterministic choice +firsts :: Process a -> [(a, Process a)] +firsts = ($ []) . rec + where + rec (p :|: q) = rec p . rec q + rec (p :?: q) = rec p . rec q + rec (a :~> p) = ((a, p):) + rec Ok = id + rec Stop = id + +{- +run :: Process a -> [[a]] +run p = + [ [] | empty p ] ++ + [ a:as | (a, q) <- firsts p, as <- run q ] -} + +scanChoice :: (a -> b -> [(a, c)]) -> a -> Process b -> Process c +scanChoice f = rec + where + rec a (p :|: q) = rec a p :|: rec a q + rec a (p :?: q) = rec a p :?: rec a q + rec a (b :~> p) = choice [ c :~> rec a2 p | (a2, c) <- f a b ] + rec _ Ok = Ok + rec _ Stop = Stop + +-- remove left-biased choice +prune :: (a -> Bool) -> Process a -> Process a +prune f = fst . fold Alg + { forChoice = \ ~(p, b1) ~(q, b2) -> (p <|> q, b1 || b2) + , forEither = \p q -> if snd p then p else q + , forPrefix = \a ~(p, b) -> (a ~> p, f a || b) + , forOk = (ok, True) + , forStop = (stop, False) + } + +useFirst :: Sequential f => (a -> Process a -> f b) -> f b -> Process a -> f b +useFirst op e = rec + where + rec (p :|: q) = rec p <|> rec q + rec (p :?: q) = rec p <?> rec q + rec (a :~> p) = op a p + rec Ok = e + rec Stop = stop + +data Sym a = Single a | Composed (Process a) + +fromAtoms :: Process (Sym a) -> Process a +fromAtoms (Single a :~> q) = a ~> fromAtoms q +fromAtoms (Composed p :~> q) = p <*> fromAtoms q +fromAtoms (p :|: q) = fromAtoms p <|> fromAtoms q +fromAtoms (p :?: q) = fromAtoms p <?> fromAtoms q +fromAtoms Ok = ok +fromAtoms Stop = stop + +atomic :: Sequential f => Process (Sym a) -> f (Sym a) +atomic = single . Composed . fromAtoms + +concurrent :: Sequential f => (a -> Bool) -> Process a -> Process a -> f a +concurrent switch = normal + where + normal p q = stepBoth q p <|> (stepRight q p <|> stepRight p q) + + stepBoth = useFirst stop2 . useFirst stop2 ok + stop2 _ _ = stop + + stepRight p = useFirst op stop + where + op a = (a ~>) . (if switch a then normal else stepRight) p + +-- Alternate combinator +(<@>) :: Sequential f => Process a -> Process a -> f a +p <@> q = useFirst (\a r -> a ~> (q <@> r)) bothOk p + where + bothOk = useFirst (\_ _ -> stop) ok q + +-------------------------------- +{- +abc, de :: Process Char +abc = 'a' :~> 'b' :~> 'c' :~> ok +de = 'd' :~> 'e' :~> ok + +go = run (concurrent undefined undefined abc de) + +indep :: Char -> Char -> Bool +indep x y = x `elem` "abc" && y `elem` "def" + +(%) :: Sequential f => Process a -> Process a -> f a +(%) = concurrent (const True) +-} +withPath :: Process a -> Process (a, Path) +withPath = rec emptyPath + where + rec path (p :|: q) = rec (toLeft path) p :|: rec (toRight path) q + rec path (p :?: q) = rec (toLeft path) p :?: rec (toRight path) q + rec path (a :~> p) = let next = tick path + in (a, next) :~> rec next p + rec _ Ok = Ok + rec _ Stop = Stop + +replay :: Monad m => Path -> Process a -> m ([a], Process a) +replay = flip (rec []) + where + rec acc process path + | path == emptyPath = return (acc, process) + | otherwise = + case process of + p :|: q -> choose p q + p :?: q -> choose p q + a :~> p -> untick path >>= rec (a:acc) p + _ -> fail "replay: invalid path" + where + choose p q = leftOrRight path >>= either (rec acc p) (rec acc q) + +-------------------------------- + +filterP :: (a -> Bool) -> Process a -> Process a +filterP p = fold idAlg + { forPrefix = \a q -> if p a then a ~> q else stop } + +idAlg :: Sequential f => Alg a (f a) +idAlg = Alg + { forChoice = (<|>) + , forEither = (<?>) + , forPrefix = (~>) + , forOk = ok + , forStop = stop + } + +tidyProcess :: (a -> a -> Bool) -> (a -> Bool) -> Process a -> Process a +tidyProcess eq cond = step2 . step1 + where + step1 = fold idAlg { forChoice = rmChoiceUnitZero + , forPrefix = rmPrefix + } + + step2 = fold idAlg { forChoice = rmSameChoice } + + rmChoiceUnitZero p q = + case (p, q) of + (Stop, _) -> q + (_, Stop) -> p + (Ok, _) -> ok + (_, Ok) -> ok + _ -> p <|> q + + rmPrefix a p | cond a = p + | otherwise = a ~> p + + rmSameChoice p q = if cmpProcesses eq p q + then p + else p <|> q + +-- | Structural comparison of processes +cmpProcesses :: (a -> b -> Bool) -> Process a -> Process b -> Bool +cmpProcesses f = rec + where + rec (p :|: q) (r :|: s) = rec p r && rec q s + rec (p :?: q) (r :?: s) = rec p r && rec q s + rec (a :~> p) (b :~> q) = f a b && rec p q + rec Ok Ok = True + rec Stop Stop = True + rec _ _ = False + +-- | The uniquePath transformation changes the process in such a way that all +-- intermediate states can only be reached by one path. A prerequisite is that +-- symbols are unique (or only used once). +uniquePath :: (a -> Bool) -> (a -> a -> Bool) -> Process a -> Process a +uniquePath cond eq = rec + where + rec (p :|: q) = let f x = not $ any (eq x) (map fst $ firstsWith cond p) + in rec p <|> rec (filterP f q) + rec (p :?: q) = rec p :?: rec q + rec (a :~> p) = a :~> rec p + rec Ok = Ok + rec Stop = Stop + +{- +prefixes :: Process a -> [[a]] +prefixes p = concatMap (\(a, q) -> [a] : (map (a:) $ prefixes q)) $ firsts p + +--uniquePath_prop :: Eq a => Process a -> Property +uniquePath_prop pred eq = unique_prop . prefixes . uniquePath pred eq + where + unique_prop xs = forAll (elements xs) $ \x -> filter (== x) xs == [x] -} + +-- | This functions returns the first symbols that hold for predicate p +firstsWith :: (a -> Bool) -> Process a -> [(a, Process a)] +firstsWith p = concatMap f . firsts + where + f (r, q) | p r = [(r, q)] + | otherwise = firstsWith p q
src/Ideas/Common/Strategy/Tests.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- Testing strategy combinator properties -- ----------------------------------------------------------------------------- +-- $Id: Tests.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Strategy.Tests (tests) where import Data.Function @@ -34,34 +36,35 @@ -- Properties tests :: TestSuite -tests = suite "Strategy combinator properties" $ do - -- monoids and semi-rings - fs (commutative : idempotent : monoidLaws :: [Law Choice]) - fs (monoidZeroLaws :: [Law Sequence]) - fs (commutative : monoidZeroLaws :: [Law Interleave]) - fs (F.distributiveLaws :: [Law Sequence]) - fs (F.distributiveLaws :: [Law Interleave]) +tests = suite "Strategy combinator properties" + [ -- monoids and semi-rings + fs (commutative : idempotent : monoidLaws :: [Law Choice]) + , fs (monoidZeroLaws :: [Law Sequence]) + , fs (commutative : monoidZeroLaws :: [Law Interleave]) + , fs (F.distributiveLaws :: [Law Sequence]) + , fs (F.distributiveLaws :: [Law Interleave]) -- properties of atomic - addProperty "atomic-twice" $ \a -> - atomic (atomic a) === atomic (idS a) - assertTrue "atomic-succeed" $ - atomic succeed === succeed - assertTrue "atomic-fail" $ - atomic fail === fail - addProperty "atomic-choice" $ \a b -> - atomic (idS a <|> idS b) === atomic a <|> atomic b + , useProperty "atomic-twice" $ \a -> + atomic (atomic a) === atomic (idS a) + , assertTrue "atomic-succeed" $ + atomic succeed === succeed + , assertTrue "atomic-fail" $ + atomic fail === fail + , useProperty "atomic-choice" $ \a b -> + atomic (idS a <|> idS b) === atomic a <|> atomic b -- splits theorm parallel/atomic - addProperty "atomic-split" $ \x y a b -> - (atomic x <*> a) <%> (atomic y <*> b) - === - (idS x <*> (a <%> (atomic y <*> b))) - <|> - (idS y <*> ((atomic x <*> idS a) <%> idS b)) + , useProperty "atomic-split" $ \x y a b -> + (atomic x <*> a) <%> (atomic y <*> b) + === + (idS x <*> (a <%> (atomic y <*> b))) + <|> + (idS y <*> ((atomic x <*> idS a) <%> idS b)) + ] where fs :: (Arbitrary a, Show a, Eq a) => [Law a] -> TestSuite - fs = mapM_ (\p -> addProperty (show p) p) + fs ps = mconcat [ useProperty (show p) p | p <- ps ] --------------------------------------------------------- -- Algebraic instances @@ -115,14 +118,13 @@ (===) :: Strategy Int -> Strategy Int -> Bool s1 === s2 = rec 100 [(start s1, start s2)] where - start = return . flip makeState 0 . toCore + start = return . makeState 0 . toCore - rec :: Int -> [([State LabelInfo Int], [State LabelInfo Int])] -> Bool + rec :: Int -> [([ParseState LabelInfo Int], [ParseState LabelInfo Int])] -> Bool rec _ [] = True rec n (pair:rest) | n == 0 = True | otherwise = testReady xs ys - && testValue xs ys && testFirsts gxs gys && rec (n-1) (rest ++ new) @@ -132,24 +134,29 @@ new = uncurry zip (mapBoth (map snd) gp) testReady = (==) `on` any (isReady . fst) - testValue = (==) `on` (nub . sort . map (value . snd)) testFirsts = (==) `on` map fst f = map merge . groupBy eqFst . sortBy cmpFst . results merge as = (fst (head as), map snd as) - results as = [ (a, b) | (Result a, b) <- as ] + results as = [ (a, b) | (a, b) <- as ] cmpFst = comparing (show . fst) eqFst = (==) `on` fst -myFirsts :: State l a -> [(Result (Step l a), State l a)] +firsts :: Bool -> ParseState l a -> [(Step l a, ParseState l a)] +firsts = undefined -- fix me + +isReady :: Step l a -> Bool +isReady = undefined -- fix me + +myFirsts :: ParseState l a -> [(Step l a, ParseState l a)] myFirsts = concatMap f . firsts False where f pair@(result, a) = case result of - Result (Enter _) -> myFirsts a - Result (Exit _) -> myFirsts a - _ -> [pair] + Enter _ -> myFirsts a + Exit _ -> myFirsts a + _ -> [pair] {- debug :: Show a => Strategy a -> a -> IO ()
src/Ideas/Common/Strategy/Traversal.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,15 +9,19 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Traversal.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Strategy.Traversal ( layer, traverse, Option -- * Options , topdown, bottomup, leftToRight, rightToLeft - , full, spine, stop, once, traversalFilter, parentFilter + , full, spine, stop, once, leftmost, rightmost + , traversalFilter, parentFilter -- * One-pass traversals - , fulltd, fullbu, oncetd, oncebu, somewhere + , fulltd, fullbu, oncetd, oncebu, leftmostbu, leftmosttd, somewhere -- * Fixpoint traversals , innermost, outermost + , ruleDown, ruleDownLast, ruleUp ) where import Data.Monoid @@ -112,6 +116,10 @@ stop = setCombinator OrElse `mappend` setVisit VisitAll once = setCombinator OrElse `mappend` setVisit VisitOne +leftmost, rightmost :: Option a +leftmost = leftToRight <> setCombinator OrElse +rightmost = rightToLeft <> setCombinator OrElse + setVisit :: Visit -> Option a setVisit v = O $ \t -> t {getVisit = v} @@ -141,17 +149,25 @@ oncebu :: (IsStrategy f, Navigator a) => f a -> Strategy a oncebu = traverse [once, bottomup] +leftmostbu :: (IsStrategy f, Navigator a) => f a -> Strategy a +leftmostbu = traverse [setCombinator OrElse, setVisit VisitFirst, bottomup] + +leftmosttd :: (IsStrategy f, Navigator a) => f a -> Strategy a +leftmosttd = traverse [setCombinator OrElse, setVisit VisitFirst, topdown] + somewhere :: (IsStrategy f, Navigator a) => f a -> Strategy a somewhere = traverse [] ---------------------------------------------------------------------- -- fixpoint traverses +-- | left-most innermost traversal. innermost :: (IsStrategy f, Navigator a) => f a -> Strategy a -innermost = repeat . oncebu +innermost = repeat . leftmostbu +-- | left-most outermost traversal. outermost :: (IsStrategy f, Navigator a) => f a -> Strategy a -outermost = repeat . oncetd +outermost = repeat . leftmosttd ---------------------------------------------------------------------- -- Navigator rules
src/Ideas/Common/Traversal/Iterator.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Iterator.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Traversal.Iterator ( -- * Iterator type class Iterator(..), isFirst, isFinal, hasNext, hasPrevious
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Navigator.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Traversal.Navigator ( -- * Location information Location, toLocation, fromLocation
src/Ideas/Common/Traversal/Tests.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Tests.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Traversal.Tests ( testIterator, testNavigator, tests , uniGen, listGen @@ -24,65 +26,74 @@ import Test.QuickCheck testIterator :: (Show a, Eq a, Iterator a) => String -> Gen a -> TestSuite -testIterator s gen = suite (s ++ " Iterator") $ do - - suite "previous/next" $ do - prop gen "previous; next" $ hasPrevious ==>> previous >=> next ==! id - prop gen "next; previous" $ hasNext ==>> next >=> previous ==! id +testIterator s gen = suite (s ++ " Iterator") + [ suite "previous/next" + [ prop gen "previous; next" $ hasPrevious ==>> previous >=> next ==! id + , prop gen "next; previous" $ hasNext ==>> next >=> previous ==! id + ] - suite "next/final" $ do - prop gen "isFinal" $ isFinal . final - prop gen "next to final" $ fixp next === final + , suite "next/final" + [ prop gen "isFinal" $ isFinal . final + , prop gen "next to final" $ fixp next === final + ] - suite "previous/first" $ do - prop gen "isFirst" $ isFirst . first - prop gen "previous to first" $ fixp previous === first + , suite "previous/first" + [ prop gen "isFirst" $ isFirst . first + , prop gen "previous to first" $ fixp previous === first + ] - suite "position" $ do - prop gen "pos previous" $ - hasPrevious ==>> fmap position . previous ==! pred . position - prop gen "pos next" $ - hasNext ==>> fmap position . next ==! succ . position - prop gen "pos first" $ - (==0) . position . first - prop gen "pos final" $ - position . final === position . fixp next + , suite "position" + [ prop gen "pos previous" $ + hasPrevious ==>> fmap position . previous ==! pred . position + , prop gen "pos next" $ + hasNext ==>> fmap position . next ==! succ . position + , prop gen "pos first" $ + (==0) . position . first + , prop gen "pos final" $ + position . final === position . fixp next + ] + ] testNavigator :: (Show a, Eq a, Navigator a) => String -> Gen a -> TestSuite -testNavigator s gen = suite (s ++ " Navigator") $ do - - suite "up/down" $ do - prop gen "down; up" $ hasDown ==>> down >=> up ==! id - prop gen "up; down" $ hasUp ==>> up >=> down ==! leftMost - prop gen "up; downLast" $ hasUp ==>> up >=> downLast ==! rightMost +testNavigator s gen = suite (s ++ " Navigator") + [ suite "up/down" + [ prop gen "down; up" $ hasDown ==>> down >=> up ==! id + , prop gen "up; down" $ hasUp ==>> up >=> down ==! leftMost + , prop gen "up; downLast" $ hasUp ==>> up >=> downLast ==! rightMost + ] - suite "left/right" $ do - prop gen "right; left" $ hasRight ==>> right >=> left ==! id - prop gen "left; right" $ hasLeft ==>> left >=> right ==! id + , suite "left/right" + [ prop gen "right; left" $ hasRight ==>> right >=> left ==! id + , prop gen "left; right" $ hasLeft ==>> left >=> right ==! id + ] - suite "up/left+right" $ do - prop gen "left; up" $ hasLeft ==>> left >=> up === up - prop gen "right; up" $ hasRight ==>> right >=> up === up + , suite "up/left+right" + [ prop gen "left; up" $ hasLeft ==>> left >=> up === up + , prop gen "right; up" $ hasRight ==>> right >=> up === up + ] - suite "down/downLast" $ do - prop gen "down; rightMost" $ liftM rightMost . down === downLast - prop gen "downLast; leftMost" $ liftM leftMost . downLast === down - prop gen "down is leftMost" $ isNothing . (down >=> left) - prop gen "downLast is rightMost" $ isNothing . (downLast >=> right) + , suite "down/downLast" + [ prop gen "down; rightMost" $ liftM rightMost . down === downLast + , prop gen "downLast; leftMost" $ liftM leftMost . downLast === down + , prop gen "down is leftMost" $ isNothing . (down >=> left) + , prop gen "downLast is rightMost" $ isNothing . (downLast >=> right) + ] - suite "location" $ do - prop gen "loc up" $ hasUp ==>> - fmap locationList . up ==! init . locationList - prop gen "loc down" $ hasDown ==>> - fmap locationList . down ==! (++[0]) . locationList - prop gen "loc downLast" $ hasDown ==>> - fmap locationList . downLast ==! (\a -> locationList a ++ [arity a-1]) - prop gen "loc left" $ hasLeft ==>> - fmap locationList . left ==! changeLast pred . locationList - prop gen "loc right" $ hasRight ==>> - fmap locationList . right ==! changeLast succ . locationList - prop gen "childnr" $ - childnr === fromMaybe 0 . listToMaybe . reverse . locationList + , suite "location" + [ prop gen "loc up" $ hasUp ==>> + fmap locationList . up ==! init . locationList + , prop gen "loc down" $ hasDown ==>> + fmap locationList . down ==! (++[0]) . locationList + , prop gen "loc downLast" $ hasDown ==>> + fmap locationList . downLast ==! (\a -> locationList a ++ [arity a-1]) + , prop gen "loc left" $ hasLeft ==>> + fmap locationList . left ==! changeLast pred . locationList + , prop gen "loc right" $ hasRight ==>> + fmap locationList . right ==! changeLast succ . locationList + , prop gen "childnr" $ + childnr === fromMaybe 0 . listToMaybe . reverse . locationList + ] + ] locationList :: Navigator a => a -> [Int] locationList = fromLocation . location @@ -91,23 +102,23 @@ -- tests tests :: TestSuite -tests = do - - suite "Iterators" $ do - 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 - - suite "Navigators" $ do - testNavigator "Uniplate" uniGen - testNavigator "Mirror" $ liftM makeMirror uniGen +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 + ] <> + suite "Navigators" + [ testNavigator "Uniplate" uniGen + , testNavigator "Mirror" $ liftM makeMirror uniGen + ] _go :: IO () -_go = runTestSuiteResult tests >>= print +_go = runTestSuiteResult True tests >>= print ------------------------------------------------------------------------- -- test utils @@ -126,7 +137,7 @@ (p ==>> f) a = p a ==> f a prop :: (Testable prop, Show a) => Gen a -> String -> (a -> prop) -> TestSuite -prop gen s = addProperty s . forAll gen +prop gen s = useProperty s . forAll gen changeLast :: (a -> a) -> [a] -> [a] changeLast _ [] = []
src/Ideas/Common/Traversal/Utils.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Utils.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Traversal.Utils ( -- * Update type class Update(..), current, change, replace, changeM, changeG
src/Ideas/Common/Utils.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- A collection of general utility functions -- ----------------------------------------------------------------------------- +-- $Id: Utils.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Utils ( Some(..), ShowString(..), readInt, readM , subsets, isSubsetOf
src/Ideas/Common/Utils/QuickCheck.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Extensions to the QuickCheck library -- ----------------------------------------------------------------------------- +-- $Id: QuickCheck.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Utils.QuickCheck ( module Test.QuickCheck -- * Data type
src/Ideas/Common/Utils/StringRef.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -15,6 +15,8 @@ -- Virutal Machine (LVM) identifiers. -- ----------------------------------------------------------------------------- +-- $Id: StringRef.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Utils.StringRef ( StringRef, stringRef, toString, tableStatus ) where
src/Ideas/Common/Utils/TestSuite.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -8,247 +8,296 @@ -- Stability : provisional -- Portability : portable (depends on ghc) -- --- A lightweight wrapper around the QuickCheck library. 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 test suite has a monadic --- interface. +-- 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. -- ----------------------------------------------------------------------------- +-- $Id: TestSuite.hs 6541 2014-05-14 18:44:36Z bastiaan $ + module Ideas.Common.Utils.TestSuite - ( -- * Test Suite Monad - TestSuite, MonadIO(..) - -- * Test suite constructors - , suite, addProperty, addPropertyWith, warn + ( -- * 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 - , TestSuiteResult, subResults, findSubResult - , messages, topMessages, numberOfTests - , makeSummary, printSummary - -- * Messages - , Message, newMessage - , isError, warning, messageLabel + , 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.State +import Control.Monad +import Data.Foldable (toList) +import Data.IORef import Data.List import Data.Maybe import Data.Monoid import Data.Time import Prelude hiding (catch) import System.IO -import Test.QuickCheck -import qualified Data.Foldable as F +import Test.QuickCheck hiding (Result) import qualified Data.Sequence as S ---------------------------------------------------------------- --- Test Suite Monad - -newtype TestSuiteM a = TSM { unTSM :: StateT Content IO a } +-- Test Suite -data Content = C - { column :: !Int -- Number of characters on the current line, for formatting - , result :: !TestSuiteResult - } +newtype TestSuite = TS (S.Seq Test) -type TestSuite = TestSuiteM () +data Test = Case String (IO Message) + | Suite String TestSuite -instance Monad TestSuiteM where - return = TSM . return - m >>= f = TSM (unTSM m >>= unTSM . f) - fail s = do assertTrue s False - return (error "TestSuite.fail: do not bind result") +instance Monoid TestSuite where + mempty = TS mempty + TS xs `mappend` TS ys = TS (xs <> ys) -instance MonadIO TestSuiteM where - liftIO = TSM . liftIO +tests :: TestSuite -> [Test] +tests (TS xs) = toList xs -instance Monoid a => Monoid (TestSuiteM a) where - mempty = return mempty - mappend = (>>) +makeTestSuite :: Test -> TestSuite +makeTestSuite = TS . S.singleton ---------------------------------------------------------------- -- Test suite constructors --- | Construct a (named) test suite containing tests and other suites -suite :: String -> TestSuite -> TestSuite -suite s m = TSM $ do - newline - liftIO $ putStrLn s - reset - t <- updateDiffTime (withEmptyTree (unTSM m)) - addResult (suiteResult s t) +-- | Construct a (named) test suite containing test cases and other suites +suite :: String -> [TestSuite] -> TestSuite +suite s = makeTestSuite . Suite s . mconcat --- | Add a QuickCheck property to the test suite. The first argument is +-- | Turn a QuickCheck property into the test suite. The first argument is -- a label for the property -addProperty :: Testable prop => String -> prop -> TestSuite -addProperty = flip addPropertyWith stdArgs +useProperty :: Testable prop => String -> prop -> TestSuite +useProperty = flip usePropertyWith stdArgs --- | Add a QuickCheck property to the test suite, also providing a test +-- | Turn a QuickCheck property into the test suite, also providing a test -- configuration (Args) -addPropertyWith :: Testable prop => String -> Args -> prop -> TestSuite -addPropertyWith s args p = TSM $ do - newlineIndent - r <- liftIO $ quickCheckWithResult args p - reset - let f = addResult . messageResult . setLabel s - maybe (addResult okResult) f (toTestResult r) +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") assertTrue :: String -> Bool -> TestSuite -assertTrue msg = assertIO msg . return +assertTrue s = assertIO s . return assertNull :: Show a => String -> [a] -> TestSuite -assertNull s xs = addAssertion (f xs) (return (null xs)) - where f = setLabel s . newMessage . intercalate "\n" . map show +assertNull s xs = assertMessages s (null xs) (map show xs) assertEquals :: (Eq a, Show a) => String -> a -> a -> TestSuite -assertEquals s x y = addAssertion (setLabel s msg) (return (x==y)) - where msg = newMessage ("Not equal: " ++ show x ++ " and " ++ show y) +assertEquals s x y = assertMessage s (x==y) $ + "not equal " ++ show x ++ " and " ++ show y -assertIO :: String -> IO Bool -> TestSuite -assertIO s = addAssertion (setLabel s $ newMessage "Assertion failed") +assertMessage :: String -> Bool -> String -> TestSuite +assertMessage s b = assertMessages s b . return -warn :: String -> TestSuite -warn = (`addAssertion` return False) . warning . newMessage +assertMessages :: String -> Bool -> [String] -> TestSuite +assertMessages s b xs = makeTestSuite . Case s $ return $ + if b then mempty else mconcat (map message xs) --- local helpers -addAssertion :: Message -> IO Bool -> TestSuite -addAssertion msg io = TSM $ do - b <- liftIO (io `catch` handler) - if b then do - dot - addResult okResult - else do - newlineIndent - liftIO (print msg) - reset - addResult (messageResult msg) +assertIO :: String -> IO Bool -> TestSuite +assertIO s = makeTestSuite . Case s . liftM f where - handler :: SomeException -> IO Bool - handler _ = return False - -withEmptyTree :: StateT Content IO () -> StateT Content IO TestSuiteResult -withEmptyTree m = do - t0 <- gets result - modify $ \c -> c {result = mempty} - m - tr <- gets result - modify $ \c -> c {result = t0} - return tr - --- formatting helpers -newline :: StateT Content IO () -newline = do - i <- gets column - when (i>0) (liftIO $ putChar '\n') - reset + f b = if b then mempty else message "assertion failed" -newlineIndent :: StateT Content IO () -newlineIndent = do - newline - liftIO $ putStr " " - modify $ \c -> c {column = 3} +assertMessageIO :: String -> IO Message -> TestSuite +assertMessageIO s = makeTestSuite . Case s -dot :: StateT Content IO () -dot = do - i <- gets column - unless (i>0 && i<60) newlineIndent - liftIO $ putChar '.' - modify $ \c -> c {column = column c+1} +-- | All errors are turned into warnings +onlyWarnings :: TestSuite -> TestSuite +onlyWarnings = changeMessages $ \m -> + m { messageStatus = messageStatus m `min` Warning + , messageRating = mempty + } -addResult :: TestSuiteResult -> StateT Content IO () -addResult r = modify $ \c -> c {result = result c `mappend` r} +rateOnError :: Int -> TestSuite -> TestSuite +rateOnError n = changeMessages $ \m -> + if isError m then m { messageRating = Rating n } else m -reset :: StateT Content IO () -reset = modify $ \c -> c {column = 0} +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 :: TestSuite -> IO () -runTestSuite = void . runTestSuiteResult +runTestSuite :: Bool -> TestSuite -> IO () +runTestSuite chattyIO = void . runTestSuiteResult chattyIO -runTestSuiteResult :: TestSuite -> IO TestSuiteResult -runTestSuiteResult s = do +runTestSuiteResult :: Bool -> TestSuite -> IO Result +runTestSuiteResult chattyIO ts = do hSetBuffering stdout NoBuffering - updateDiffTime $ liftM result $ - execStateT (unTSM s >> newline) (C 0 mempty) + ref <- newIORef 0 + result <- runner ref chattyIO ts + newline ref + return result + where ----------------------------------------------------------------- --- Test Suite 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 } -data TestSuiteResult = TSR - { messageSeq :: S.Seq Message - , suiteSeq :: S.Seq (String, TestSuiteResult) - , numberOfTests :: !Int - , diffTime :: !NominalDiffTime - } + runTest :: Test -> IO Result + runTest t = + case t of + Suite s xs -> runSuite s xs + Case s io -> runTestCase s io -instance Monoid TestSuiteResult where - mempty = TSR mempty mempty 0 0 - mappend x y = TSR - { messageSeq = messageSeq x `mappend` messageSeq y - , suiteSeq = suiteSeq x `mappend` suiteSeq y - , numberOfTests = numberOfTests x + numberOfTests y - , diffTime = diffTime x + diffTime y - } + 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) -okResult :: TestSuiteResult -okResult = mempty {numberOfTests = 1} + 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 -messageResult :: Message -> TestSuiteResult -messageResult m = okResult {messageSeq = S.singleton m} + addTest :: Result -> Test -> IO Result + addTest res t = liftM (res <>) (runTest t) -suiteResult :: String -> TestSuiteResult -> TestSuiteResult -suiteResult s a = mempty - { suiteSeq = S.singleton (s, a) - , numberOfTests = numberOfTests a +-- 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 TestSuiteResult where - show res = - let (xs, ys) = partition isError (messages res) - in "(tests: " ++ show (numberOfTests res) ++ - ", errors: " ++ show (length xs) ++ - ", warnings: " ++ show (length ys) ++ - ", " ++ show (diffTime res) ++ ")" +instance Show Result where + show result = + "(tests: " ++ show (nrOfTests result) ++ + ", errors: " ++ show (nrOfErrors result) ++ + ", warnings: " ++ show (nrOfWarnings result) ++ + ", " ++ show (diffTime result) ++ ")" -subResults :: TestSuiteResult -> [(String, TestSuiteResult)] -subResults = F.toList . suiteSeq +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 + } -topMessages :: TestSuiteResult -> [Message] -topMessages = F.toList . messageSeq +instance HasStatus Result where + getStatus r | nrOfErrors r > 0 = Error + | nrOfWarnings r > 0 = Warning + | otherwise = Ok -messages :: TestSuiteResult -> [Message] -messages res = - topMessages res ++ concatMap (messages . snd) (subResults res) +instance HasRating Result where + rating = rating . resultRating + rate n a = a {resultRating = Rating n} -data Message = Message - { message :: String - , isError :: Bool - , messageLabel :: Maybe String +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 } -instance Show Message where - show a = (if null pre then "" else pre ++ ": ") ++ message a - where - parens s = "(" ++ s ++ ")" - pre = unwords $ - [ "Warning" | not (isError a) ] ++ - maybe [] (return . parens) (messageLabel a) +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 + } -newMessage :: String -> Message -newMessage s = Message s True Nothing +subResults :: Result -> [(String, Result)] +subResults = toList . suites -warning :: Message -> Message -warning m = m {isError = False} +topMessages :: Result -> [(String, Message)] +topMessages = toList . cases -setLabel :: String -> Message -> Message -setLabel s m = m {messageLabel = Just s} +allMessages :: Result -> [(String, Message)] +allMessages res = + topMessages res ++ concatMap (allMessages . snd) (subResults res) -findSubResult :: String -> TestSuiteResult -> Maybe TestSuiteResult +findSubResult :: String -> Result -> Maybe Result findSubResult name = listToMaybe . recs where recs = concatMap rec . subResults @@ -256,45 +305,117 @@ | n == name = [t] | otherwise = recs t -printSummary :: TestSuiteResult -> IO () +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 :: TestSuiteResult -> String -makeSummary res = unlines $ +makeSummary :: Result -> String +makeSummary result = unlines $ [ line - , "Tests : " ++ show (numberOfTests res) - , "Failures : " ++ show (length xs) - , "Warnings : " ++ show (length ys) - , "\nTime : " ++ show (diffTime res) - , "\nSuites: " - ] ++ map f (subResults res) + , "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 '-' - (xs, ys) = partition isError (messages res) + line = replicate 75 '-' f (name, r) = " " ++ name ++ " " ++ show r ----------------------------------------------------- --- Utility functions +-- Message -toTestResult :: Result -> Maybe Message -toTestResult res = - let make = Just . newMessage - in case res of - Success {} -> Nothing - Failure {reason = msg} -> make msg - NoExpectedFailure {} -> make "no expected failure" - GaveUp {numTests = i} -> fmap warning $ make $ - "passed only " ++ show i ++ " tests" +data Message = M + { messageStatus :: !Status + , messageRating :: !Rating + , messageLines :: [String] + } + deriving Eq -updateDiffTime :: MonadIO m => m TestSuiteResult -> m TestSuiteResult -updateDiffTime m = do - (res, d) <- getDiffTime m - return res {diffTime = d} +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 = "" -getDiffTime :: MonadIO m => m a -> m (a, NominalDiffTime) +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 <- liftIO getCurrentTime + t0 <- getCurrentTime a <- action - t1 <- liftIO getCurrentTime - return (a, diffUTCTime t1 t0)+ t1 <- getCurrentTime + return (a, diffUTCTime t1 t0) + +returnStrict :: Monad m => a -> m a +returnStrict a = a `seq` return a
src/Ideas/Common/Utils/Uniplate.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- class and its utility plus constructor functions) -- ----------------------------------------------------------------------------- +-- $Id: Uniplate.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.Utils.Uniplate ( -- * Uniplate type class and utility functions Uniplate
src/Ideas/Common/View.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -13,6 +13,8 @@ -- in Interactive Exercise Assistants" -- ----------------------------------------------------------------------------- +-- $Id: View.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Common.View ( Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..) , Control.Arrow.ArrowZero(..), Control.Arrow.ArrowPlus(..) @@ -177,7 +179,7 @@ changeId f a = f mempty :@ a instance Identify (View a b) where - n @> v | isEmptyId a = v + n @> v | a == mempty = v | otherwise = a :@ v where a = newId n
src/Ideas/Encoding/DecoderJSON.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,13 +12,14 @@ -- Services using JSON notation -- ----------------------------------------------------------------------------- +-- $Id: DecoderJSON.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.DecoderJSON ( JSONDecoder, JSONDecoderState(..), jsonDecoder ) where import Control.Monad import Ideas.Common.Library hiding (exerciseId) -import Ideas.Common.Utils (readM) import Ideas.Encoding.Evaluator import Ideas.Service.FeedbackScript.Syntax (Script) import Ideas.Service.State @@ -76,6 +77,7 @@ Location -> decodeLocation Int -> maybeEncoder fromJSON Tp.String -> maybeEncoder fromJSON + Id -> decodeId Rule -> decodeRule _ -> fail $ "No support for argument type: " ++ show tp @@ -87,6 +89,12 @@ String s -> getRule ex (newId s) _ -> fail "expecting a string for rule" +decodeId :: JSONDecoder a Id +decodeId = encoderFor $ \json -> + case json of + String s -> return (newId s) + _ -> fail "expecting a string for id" + decodeLocation :: JSONDecoder a Location decodeLocation = encoderFor $ \json -> case json of @@ -100,19 +108,19 @@ case json of Array [a] -> decodeState // a Array [String _code, pref, term, jsonContext] -> do - ps <- decodePrefixes // pref + iss <- decodePrefixes // pref a <- decodeTerm // term env <- decodeEnvironment // jsonContext - return $ makeState ex ps (makeContext ex env a) + let ctx = setEnvironment env (inContext ex a) + ps <- mapM (\is -> makePrefix is (strategy ex) ctx) iss + return $ makeState ex ps ctx _ -> fail $ "invalid state" ++ show json -decodePrefixes :: JSONDecoder a [Prefix (Context a)] -decodePrefixes = do - ex <- withState getExercise +decodePrefixes :: JSONDecoder a [Path] +decodePrefixes = encoderFor $ \json -> case json of - String p -> forM (deintercalate p) $ - readM >>= liftM (`makePrefix` strategy ex) + String p -> mapM readM (deintercalate p) _ -> fail "invalid prefixes" decodeEnvironment :: JSONDecoder a Environment
src/Ideas/Encoding/DecoderXML.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- +-- $Id: DecoderXML.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.DecoderXML ( XMLDecoder, XMLDecoderState(..), xmlDecoder ) where @@ -19,8 +21,8 @@ import Control.Monad import Data.Char import Data.List +import Data.Maybe import Ideas.Common.Library hiding (exerciseId, (:=)) -import Ideas.Common.Utils (readM) import Ideas.Encoding.Evaluator import Ideas.Encoding.OpenMathSupport import Ideas.Service.FeedbackScript.Syntax (Script) @@ -93,24 +95,22 @@ decodeState :: XMLDecoder a (State a) decodeState = do - ex <- withState getExercise - xml <- encoderFor (findChild "state") - mpr <- decodePrefix // xml - term <- decodeContext // xml - return (makeState ex mpr term) + ex <- withState getExercise + xml <- encoderFor (findChild "state") + mp <- decodePrefix // xml + ctx <- decodeContext // xml + prs <- forM (maybeToList mp) $ \path -> + makePrefix path (strategy ex) ctx + return (makeState ex prs ctx) -decodePrefix :: XMLDecoder a [Prefix (Context a)] +decodePrefix :: XMLDecoder a (Maybe Path) decodePrefix = do - str <- liftM strategy (withState getExercise) prefixText <- simpleEncoder (maybe "" getData . findChild "prefix") if all isSpace prefixText - then return [emptyPrefix str] + then return (Just emptyPath) else if prefixText ~= "no prefix" - then return [] - else do - a <- readM prefixText - pr <- makePrefix a str - return [pr] + then return Nothing + else liftM Just (readM prefixText) where a ~= b = g a == g b g = map toLower . filter (not . isSpace) @@ -121,7 +121,7 @@ f <- withState decodeTerm expr <- encoderFor (either fail return . f) env <- decodeEnvironment - return (makeContext ex env expr) + return (setEnvironment env (inContext ex expr)) decodeEnvironment :: XMLDecoder a Environment decodeEnvironment = encoderFor $ \xml ->
src/Ideas/Encoding/EncoderHTML.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- Encoding in HTML -- ----------------------------------------------------------------------------- +-- $Id: EncoderHTML.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.EncoderHTML (htmlEncoder) where import Control.Monad @@ -20,8 +22,8 @@ import Data.Maybe import Data.Ord import Ideas.Common.Library hiding (ready) -import Ideas.Common.Strategy.Prefix import Ideas.Common.Utils +import Ideas.Common.Utils.TestSuite import Ideas.Encoding.Evaluator import Ideas.Encoding.LinkManager import Ideas.Encoding.RulePresenter @@ -46,11 +48,11 @@ htmlEncoder :: LinkManager -> DomainReasoner -> Exercise a -> TypedValue (Type a) -> HTMLPage htmlEncoder lm dr ex tv = - addCSS (resource "ideas.css") $ + addCSS (urlForCSS lm "ideas.css") $ htmlPage "Ideas: documentation pages" $ mconcat [ divClass "page-header" $ mconcat - [ divClass "ideas-logo" $ image $ resource "ideas.png" - , divClass "ounl-logo" $ image $ resource "ounl.png" + [ divClass "ideas-logo" space + , divClass "ounl-logo" space , spanClass "menuitem" $ linkToIndex lm $ string "Index" , spanClass "menuitem" $ linkToExercises lm $ string "Exercises" , spanClass "menuitem" $ linkToServices lm $ string "Services" @@ -63,8 +65,6 @@ , divClass "page-footer" $ string (fullVersion dr) ] - where - resource = urlForResource lm encodeType :: LinkManager -> Exercise a -> HTMLEncoder a (TypedValue (Type a)) encodeType lm ex = msum @@ -104,6 +104,7 @@ Environment -> text val Context -> string $ prettyPrinterContext ex val String -> string val + Result -> (exerciseHeader // ()) <> encodeResult lm val _ -> text tv encodeIndex :: HTMLEncoder a DomainReasoner @@ -264,6 +265,7 @@ , with linkToRules "rules" , with linkToExamples "examples" , with linkToDerivations "derivations" + , with linkToTestReport "test report" ] where with f s = do @@ -288,6 +290,76 @@ bool :: Bool -> HTMLBuilder bool b = string (if b then "yes" else "no") +encodeResult :: BuildXML b => LinkManager -> Result -> b +encodeResult lm tests = mconcat + [ h2 "Test report" + , divClass "test-summary" $ mconcat + [ divClass "test-status" (statusImg lm tests 32) + , keyValueTable + [ ("Tests", text (nrOfTests tests)) + , ("Errors", text (nrOfErrors tests)) + , ("Warnings", text (nrOfWarnings tests)) + , ("Time", string (show (timeInterval tests) ++ "s")) + , ("Rating", showRating lm $ fromMaybe 10 $ rating tests) + ] + , h3 "Suites" + , ul [ string s <> space <> text t + | (s, t) <- subResults tests + ] + ] + , mwhen (isError tests) $ + mconcat (h2 "Errors" : map makeItem errors) + , mwhen (isWarning tests) $ + mconcat (h2 "Warnings" : map makeItem warnings) + , h2 "Tests" + , make tests + ] + where + msgs = allMessages tests + errors = filter (isError . snd) msgs + warnings = filter (isWarning . snd) msgs + + make t = mconcat $ + map makeGroup (subResults t) ++ + map makeItem (topMessages t) + + makeGroup (s, t) = divClass "test-group" $ + divClass "test-title" (string (s ++ " " ++ show t)) + <> make t + + makeItem (s, m) = divClass "test-item" $ + statusImg lm m 16 <> spaces 3 <> string s <> msg + where + msg | isOk m = mempty + | otherwise = string ": " <> string (intercalate "," (messageLines m)) + +statusImg :: (HasStatus a, BuildXML b) => LinkManager -> a -> Int -> b +statusImg lm a n = element "img" + [ "src" .=. urlForImage lm (statusSrc a) + , "height" .=. show n + , "width" .=. show n + ] + +statusSrc :: HasStatus a => a -> String +statusSrc a + | isError a = "stop.png" + | isWarning a = "flagblue.png" + | otherwise = "ok.png" + +showRating :: BuildXML a => LinkManager -> Int -> a +showRating lm = rec (5::Int) + where + rec 0 _ = mempty + rec n a = element "img" + [ "src" .=. urlForImage lm png + , "height" .=. "16" + , "width" .=. "16" + ] <> rec (n-1) (a-2) + where + png | a >= 2 = "star.png" + | a == 1 = "star_2.png" + | otherwise = "star_3.png" + encodeRuleList :: LinkManager -> Exercise a -> HTMLEncoder a [Rule (Context a)] encodeRuleList lm ex = simpleEncoder $ \rs -> let (rs1, rs2) = partition isBuggy rs @@ -345,12 +417,15 @@ ] where make (_, x) = para $ - munless (isStatic lm) $ + munless (isStatic lm) ( let st = emptyStateContext ex x - in spanClass "statelink" $ linkToState lm st $ - element "img" ["src" .=. "external.png", "width" .=. "15"] + in spanClass "statelink" $ linkToState lm st $ external lm) <> spanClass "term" (string (prettyPrinterContext ex x)) +external :: BuildXML a => LinkManager -> a +external lm = element "img" + ["src" .=. urlForImage lm "external.png", "width" .=. "15"] + encodeDerivation :: LinkManager -> Exercise a -> HTMLEncoder a (Derivation (Rule (Context a), Environment) (Context a)) encodeDerivation lm ex = h2 "Derivation" <> htmlDerivation lm ex @@ -365,7 +440,7 @@ htmlDerivation :: LinkManager -> Exercise a -> HTMLEncoder a (Derivation (Rule (Context a), Environment) (Context a)) htmlDerivation lm ex = encoderFor $ \d -> - arr derivationDiffEnv + arr diffEnvironment >>> htmlDerivationWith (before d) forStep forTerm where before d = @@ -395,11 +470,7 @@ stateLink :: LinkManager -> State a -> HTMLBuilder stateLink lm st = munless (isStatic lm) $ - spanClass "derivation-statelink" $ linkToState lm st $ - element "img" - [ "src" .=. urlForResource lm "external.png" - , "width" .=. "15" - ] + spanClass "derivation-statelink" $ linkToState lm st $ external lm encodeState :: HTMLEncoder a (State a) encodeState = do @@ -476,10 +547,13 @@ case diagnosis of Buggy _ r -> spanClass "error" $ string $ "Not equivalent: buggy rule " ++ show r - NotEquivalent -> - spanClass "error" $ string "Not equivalent" + NotEquivalent s -> + spanClass "error" $ string $ if null s then "Not equivalent" else s Similar _ s -> h2 "Similar term" <> encodeState // s + WrongRule _ s mr -> + h2 ("WrongRule " ++ maybe "" showId mr) + <> encodeState // s Expected _ s r -> h2 ("Expected (" ++ show r ++ ")") <> encodeState // s @@ -488,6 +562,8 @@ <> encodeState // s Correct _ s -> h2 "Correct" <> encodeState // s + Unknown _ s -> + h2 "Unknown" <> encodeState // s htmlDescription :: HasId a => a -> HTMLBuilder htmlDescription a = munless (null (description a)) $
src/Ideas/Encoding/EncoderJSON.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- Services using JSON notation -- ----------------------------------------------------------------------------- +-- $Id: EncoderJSON.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.EncoderJSON (jsonEncoder) where import Control.Monad @@ -95,7 +97,7 @@ let f x = [ String (showId (exercise st)) , String $ case statePrefixes st of [] -> "NoPrefix" - ps -> intercalate ";" $ map show ps + ps -> intercalate ";" $ map showPrefix ps , encTerm (stateTerm st) , x ] @@ -122,8 +124,9 @@ [ ("result", String "Buggy") , ("rules", Array $ map (String . showId) rs) ] - Submit.NotEquivalent -> pure - [ ("result", String "NotEquivalent") ] + Submit.NotEquivalent s -> pure $ + ("result", String "NotEquivalent") : + [ ("reason", String s) | not (null s)] Submit.Ok rs st -> let f x = [ ("result", String "Ok") @@ -148,24 +151,31 @@ encodeDiagnosis :: JSONEncoder a (Diagnose.Diagnosis a) encodeDiagnosis = encoderFor $ \diagnosis -> case diagnosis of - Diagnose.NotEquivalent -> - pure $ Object [("notequiv", Null)] + Diagnose.NotEquivalent s -> + if null s then pure (Object [("notequiv", Null)]) + else make "notequiv" [fromReason s] Diagnose.Buggy env r -> make "buggy" [fromEnv env, fromRule r] Diagnose.Similar b st -> make "similar" [fromReady b, fromState st] + Diagnose.WrongRule b st mr -> + make "wrongrule" [fromReady b, fromState st, fromMaybeRule mr] Diagnose.Expected b st r -> make "expected" [fromReady b, fromState st, fromRule r] Diagnose.Detour b st env r -> make "detour" [fromReady b, fromState st, fromEnv env, fromRule r] Diagnose.Correct b st -> make "correct" [fromReady b, fromState st] + Diagnose.Unknown b st -> + make "unknown" [fromReady b, fromState st] where make s = liftM (\xs -> Object [(s, Array xs)]) . sequence - fromEnv env = jsonEncoder // (env ::: typed) - fromRule r = return (toJSON (showId r)) - fromReady b = return (Object [("ready", toJSON b)]) - fromState st = jsonEncoder // (st ::: typed) + fromEnv env = jsonEncoder // (env ::: typed) + fromRule r = return (toJSON (showId r)) + fromMaybeRule mr = return (maybe Null (toJSON . showId) mr) + fromReady b = return (Object [("ready", toJSON b)]) + fromState st = jsonEncoder // (st ::: typed) + fromReason s = return (Object [("reason", toJSON s)]) {- encodeTree :: Tree JSON -> JSON
src/Ideas/Encoding/EncoderXML.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- +-- $Id: EncoderXML.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.EncoderXML ( XMLEncoder, XMLEncoderState(..) , xmlEncoder, encodeState @@ -108,7 +110,7 @@ encodePrefixes = encoderFor $ \ps -> case ps of [] -> mempty - _ -> element "prefix" [ text p | p <- ps ] + _ -> element "prefix" $ map (string . showPrefix) ps encodeContext :: XMLEncoder a (Context a) encodeContext = encoderStateFor $ \xp ctx -> @@ -195,10 +197,14 @@ case diagnosis of Buggy env r -> element "buggy" [encodeEnvironment // env, "ruleid" .=. showId r] - NotEquivalent -> - return (emptyTag "notequiv") + NotEquivalent s -> + if null s then return (emptyTag "notequiv") + else element "notequiv" [ "reason" .=. s ] Similar b st -> element "similar" ["ready" .=. showBool b, encodeState // st] + WrongRule b st mr -> element "wrongrule" $ + [ "ready" .=. showBool b, encodeState // st ] ++ + maybe [] (\r -> ["ruleid" .=. showId r]) mr Expected b st r -> element "expected" ["ready" .=. showBool b, encodeState // st, "ruleid" .=. showId r] Detour b st env r -> element "detour" @@ -206,6 +212,8 @@ , encodeEnvironment // env, "ruleid" .=. showId r ] Correct b st -> element "correct" + ["ready" .=. showBool b, encodeState // st] + Unknown b st -> element "unknown" ["ready" .=. showBool b, encodeState // st] encodeDecompositionReply :: XMLEncoder a (PD.Reply a)
src/Ideas/Encoding/Evaluator.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Evaluator.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.Evaluator ( EncoderState, simpleEncoder, maybeEncoder, eitherEncoder , encoderFor, encoderStateFor, encodeTyped @@ -142,42 +144,15 @@ ------------------------------------------------------------------- -evalService :: Monad m => Evaluator a m b -> Service -> m b +evalService :: Evaluator a b -> Service -> IO b evalService f = eval f . serviceFunction -data Evaluator a m b where - Evaluator :: (TypedValue (Type a) -> m b) -- encoder - -> (forall t . Type a t -> m t) -- decoder - -> Evaluator a m b - -{- -type Fix a = a -> a - -encodeTypeRep :: Monoid a => (TypedValue f -> a) -> TypedValue (TypeRep f) -> a -encodeTypeRep = fix . encodeTypeRepFix - -encodeTypeRepFix :: Monoid a => (TypedValue f -> a) -> Fix (TypedValue (TypeRep f) -> a) -encodeTypeRepFix enc rec (val ::: tp) = - case tp of - _ :-> _ -> mempty - t1 :|: t2 -> case val of - Left a -> rec (a ::: t1) - Right a -> rec (a ::: t2) - Pair t1 t2 -> rec (fst val ::: t1) <> rec (snd val ::: t2) - List t -> mconcat (map (rec . (::: t)) val) - Tree t -> F.fold (fmap (rec . (::: t)) val) - Unit -> mempty - Tag _ t -> rec (val ::: t) - Iso v t -> rec (to v val ::: t) - Const ctp -> enc (val ::: ctp) - -encodeWith :: (Monad m, Typed a t) => (t -> m b) -> TypedValue (Type a) -> m b -encodeWith enc (val ::: tp) = - case equal tp typed of - Just f -> enc (f val) - Nothing -> fail "encoding failed" -} +data Evaluator a b where + Evaluator :: (TypedValue (Type a) -> IO b) -- encoder + -> (forall t . Type a t -> IO t) -- decoder + -> Evaluator a b -eval :: Monad m => Evaluator a m b -> TypedValue (Type a) -> m b +eval :: Evaluator a b -> TypedValue (Type a) -> IO b eval f@(Evaluator enc dec) tv@(val ::: tp) = case tp of -- handle exceptions @@ -189,5 +164,9 @@ t1 :-> t2 -> do a <- dec t1 eval f (val a ::: t2) + -- perform IO + IO t -> do + a <- val + eval f (a ::: t) _ -> enc tv
src/Ideas/Encoding/LinkManager.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- Manages links to information -- ----------------------------------------------------------------------------- +-- $Id: LinkManager.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.LinkManager ( LinkManager(..) , dynamicLinks, stateToXML @@ -20,7 +22,7 @@ , linkToIndex, linkToExercises, linkToServices, linkToService -- links to exercise information , linkToExercise, linkToStrategy, linkToRules, linkToExamples - , linkToDerivations, linkToRule, linkToRandomExample + , linkToDerivations, linkToRule, linkToRandomExample, linkToTestReport -- links to state information (dynamic) , linkToState, linkToFirsts, linkToApplications, linkToDerivation ) where @@ -35,7 +37,8 @@ import Ideas.Text.XML data LinkManager = LinkManager - { urlForResource :: String -> String + { urlForCSS :: String -> String + , urlForImage :: String -> String , urlForRequest :: String , isStatic :: Bool -- links to services and exercises @@ -50,6 +53,7 @@ , urlForExamples :: forall a . Exercise a -> String , urlForDerivations :: forall a . Exercise a -> String , urlForRule :: forall a . Exercise a -> Rule (Context a) -> String + , urlForTestReport :: forall a . Exercise a -> String -- dynamic exercise information , urlForRandomExample :: forall a . Exercise a -> Difficulty -> String -- dynamic state information @@ -95,6 +99,9 @@ linkToRule :: LinkManager -> Exercise a -> Rule (Context a) -> HTMLBuilder -> HTMLBuilder linkToRule lm = linkWith . urlForRule lm +linkToTestReport :: LinkManager -> Exercise a -> HTMLBuilder -> HTMLBuilder +linkToTestReport = linkWith . urlForTestReport + --------------------------------------------------------------------- -- dynamic exercise information @@ -123,7 +130,8 @@ dynamicLinks cgiBinary = LinkManager { isStatic = False , urlForRequest = prefix - , urlForResource = id + , urlForCSS = ("http://ideas.cs.uu.nl/css/" ++) + , urlForImage = ("http://ideas.cs.uu.nl/images/" ++) , urlForIndex = url $ simpleRequest "index" , urlForExercises = url $ simpleRequest "exerciselist" , urlForServices = url $ simpleRequest "servicelist" @@ -132,6 +140,7 @@ , urlForExercise = url . exerciseRequest "exerciseinfo" , urlForStrategy = url . exerciseRequest "strategyinfo" , urlForRules = url . exerciseRequest "rulelist" + , urlForTestReport = url . exerciseRequest "testreport" , urlForExamples = url . exerciseRequest "examples" , urlForDerivations = url . exerciseRequest "examplederivations" , urlForRule = \ex r -> @@ -196,7 +205,8 @@ staticLinks :: LinkManager staticLinks = LinkManager { isStatic = True - , urlForResource = id + , urlForCSS = id + , urlForImage = id , urlForRequest = "" , -- links to services and exercises urlForIndex = "index.html" @@ -210,6 +220,7 @@ , 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 @@ -222,7 +233,6 @@ linksUp :: Int -> LinkManager -> LinkManager linksUp n lm = lm { isStatic = isStatic lm - , urlForResource = f1 urlForResource -- links to services and exercises , urlForIndex = f0 urlForIndex , urlForExercises = f0 urlForExercises
src/Ideas/Encoding/ModeJSON.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,9 +11,10 @@ -- Services using JSON notation -- ----------------------------------------------------------------------------- +-- $Id: ModeJSON.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.ModeJSON (processJSON) where -import Control.Monad import Data.Char import Ideas.Common.Library hiding (exerciseId) import Ideas.Common.Utils (Some(..), timedSeconds) @@ -21,16 +22,18 @@ import Ideas.Encoding.EncoderJSON import Ideas.Encoding.Evaluator import Ideas.Service.DomainReasoner +import Ideas.Service.FeedbackScript.Syntax (Script) import Ideas.Service.Request import Ideas.Text.JSON import System.Random hiding (getStdGen) -processJSON :: Bool -> DomainReasoner -> String -> IO (Request, String, String) -processJSON cgiMode dr input = do +processJSON :: Maybe Int -> Bool -> DomainReasoner -> String -> IO (Request, String, String) +processJSON maxTime cgiMode dr input = do json <- either fail return (parseJSON input) req <- jsonRequest json - resp <- jsonRPC json (myHandler dr) - let f = if cgiMode then showCompact else showPretty + resp <- jsonRPC json $ \fun arg -> + maybe id timedSeconds maxTime (myHandler dr fun arg) + let f = if compactOutputDefault cgiMode req then compactJSON else show out = addVersion (version dr) (toJSON resp) return (req, f out, "application/json") @@ -62,8 +65,8 @@ _ -> fail "Invalid method" let a = lookupM "params" json >>= extractExerciseId enc <- case lookupM "encoding" json of - Nothing -> return Nothing - Just (String s) -> liftM Just (readEncoding s) + Nothing -> return [] + Just (String s) -> readEncoding s _ -> fail "Invalid encoding" src <- case lookupM "source" json of Nothing -> return Nothing @@ -77,19 +80,20 @@ , encoding = enc } -myHandler :: DomainReasoner -> RPCHandler IO -myHandler dr fun arg = timedSeconds 5 $ do +myHandler :: DomainReasoner -> RPCHandler +myHandler dr fun json = do srv <- findService dr (newId fun) Some ex <- if fun == "exerciselist" then return (Some emptyExercise) - else extractExerciseId arg >>= findExercise dr + else extractExerciseId json >>= findExercise dr script <- defaultScript dr (getId ex) stdgen <- newStdGen - let jds = JSONDecoderState ex script stdgen - runEncoderStateM (evalService (jsonConverter ex) srv) jds arg + evalService (jsonConverter script ex stdgen json) srv -jsonConverter :: Exercise a -> Evaluator a (JSONDecoder a) JSON -jsonConverter ex = Evaluator +jsonConverter :: Script -> Exercise a -> StdGen -> JSON -> Evaluator a JSON +jsonConverter script ex stdgen json = Evaluator (runEncoderStateM jsonEncoder (String . prettyPrinter ex)) - jsonDecoder+ (\tp -> runEncoderStateM (jsonDecoder tp) jds json) + where + jds = JSONDecoderState ex script stdgen
src/Ideas/Encoding/ModeXML.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,10 +11,12 @@ -- Services using XML notation -- ----------------------------------------------------------------------------- +-- $Id: ModeXML.hs 6541 2014-05-14 18:44:36Z bastiaan $ + module Ideas.Encoding.ModeXML (processXML) where +import Control.Exception import Control.Monad -import Control.Monad.Error import Data.Maybe import Ideas.Common.Library hiding (exerciseId, (:=)) import Ideas.Common.Utils (Some(..), timedSeconds) @@ -31,21 +33,25 @@ import Ideas.Text.HTML import Ideas.Text.OpenMath.Object import Ideas.Text.XML -import System.IO.Error +import Prelude hiding (catch) +import System.IO.Error hiding (catch) import System.Random (StdGen, newStdGen) -processXML :: DomainReasoner -> Maybe String -> String -> IO (Request, String, String) -processXML dr cgiBin input = do +processXML :: Maybe Int -> DomainReasoner -> Maybe String -> String -> IO (Request, String, String) +processXML maxTime dr cgiBin input = do xml <- either fail return (parseXML input) req <- either fail return (xmlRequest xml) - resp <- timedSeconds 5 (xmlReply dr cgiBin req xml) - `catchError` (return . resultError . ioeGetErrorString) - case encoding req of - Just HTMLEncoding -> - return (req, show resp, "text/html") - _ -> let out = addVersion (version dr) resp - f = if isNothing cgiBin then showXML else show - in return (req, f out, "application/xml") + resp <- maybe id timedSeconds maxTime (xmlReply dr cgiBin req xml) + `catch` handler + let showXML | compactOutputDefault (isJust cgiBin) req = compactXML + | otherwise = show + if htmlOutput req + then return (req, showXML resp, "text/html") + else let out = addVersion (version dr) resp + in return (req, showXML out, "application/xml") + where + handler :: IOException -> IO XML + handler = return . resultError . ioeGetErrorString addVersion :: String -> XML -> XML addVersion s xml = @@ -59,8 +65,8 @@ srv <- findAttribute "service" xml let a = extractExerciseId xml enc <- case findAttribute "encoding" xml of - Just s -> liftM Just (readEncoding s) - Nothing -> return Nothing + Just s -> readEncoding s + Nothing -> return [] return Request { service = srv , exerciseId = a @@ -86,18 +92,21 @@ | getId ex == mempty -> return mempty | otherwise -> defaultScript dr (getId ex) stdgen <- newStdGen - case encoding request of - Just StringEncoding -> do - res <- evalService (stringFormatConverter script ex stdgen xml) srv - return (resultOk res) - Just HTMLEncoding -> do + -- HTML encoder + if htmlOutput request + then do res <- evalService (htmlConverter dr cgiBin script ex stdgen xml) srv return (toXML res) - - _ -> do + -- OpenMath encoder + else if useOpenMath request + then do res <- evalService (openMathConverter True script ex stdgen xml) srv return (resultOk res) + -- String encoder + else do + res <- evalService (stringFormatConverter script ex stdgen xml) srv + return (resultOk res) extractExerciseId :: Monad m => XML -> m Id extractExerciseId = liftM newId . findAttribute "exerciseid" @@ -115,7 +124,7 @@ ------------------------------------------------------------ -- Mixing abstract syntax (OpenMath format) and concrete syntax (string) -stringFormatConverter :: Script -> Exercise a -> StdGen -> XML -> Evaluator a IO XMLBuilder +stringFormatConverter :: Script -> Exercise a -> StdGen -> XML -> Evaluator a XMLBuilder stringFormatConverter script ex stdgen xml = Evaluator (runEncoderStateM xmlEncoder xes) (\tp -> runEncoderStateM (xmlDecoder tp) xds xml) @@ -124,14 +133,14 @@ xds = XMLDecoderState ex script stdgen False g g = (liftM getData . findChild "expr") >=> parser ex -htmlConverter :: DomainReasoner -> Maybe String -> Script -> Exercise a -> StdGen -> XML -> Evaluator a IO HTMLPage +htmlConverter :: DomainReasoner -> Maybe String -> Script -> Exercise a -> StdGen -> XML -> Evaluator a HTMLPage htmlConverter dr cgiBin script ex stdgen xml = Evaluator (return . htmlEncoder lm dr ex) d where lm = maybe staticLinks dynamicLinks cgiBin Evaluator _ d = stringFormatConverter script ex stdgen xml -openMathConverter :: Bool -> Script -> Exercise a -> StdGen -> XML -> Evaluator a IO XMLBuilder +openMathConverter :: Bool -> Script -> Exercise a -> StdGen -> XML -> Evaluator a XMLBuilder openMathConverter withMF script ex stdgen xml = Evaluator (runEncoderStateM xmlEncoder xes) (\tp -> runEncoderStateM (xmlDecoder tp) xds xml)
src/Ideas/Encoding/OpenMathSupport.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: OpenMathSupport.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.OpenMathSupport ( -- * Conversion functions to/from OpenMath toOpenMath, fromOpenMath, noMixedFractions
src/Ideas/Encoding/RulePresenter.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: RulePresenter.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.RulePresenter (ruleToHTML) where import Data.List
src/Ideas/Encoding/RulesInfo.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: RulesInfo.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.RulesInfo ( rulesInfoXML, rewriteRuleToFMP, collectExamples, ExampleMap ) where @@ -66,7 +68,7 @@ collectExamples :: Exercise a -> ExampleMap a collectExamples ex = foldr (add . snd) M.empty (examples ex) where - add a m = let tree = derivationTree False (strategy ex) (inContext ex a) + add a m = let tree = derivationTree (strategy ex) (inContext ex a) f Nothing = m f (Just d) = foldr g m (triples d) g (x, (r, _), y) =
src/Ideas/Encoding/StrategyInfo.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Converting a strategy to XML, and the other way around. -- ----------------------------------------------------------------------------- +-- $Id: StrategyInfo.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Encoding.StrategyInfo (strategyToXML, xmlToStrategy) where import Control.Monad @@ -51,22 +53,21 @@ _ :|: _ -> asList "choice" isChoice _ :|>: _ -> asList "orelse" isOrElse _ :%: _ -> asList "interleave" isInterleave - a :!%: b -> tag "interleft" (rec a <> rec b) - Many a -> tag "many" (rec a) - Repeat a -> tag "repeat" (rec a) + a :@: b -> tag "alternate" (rec a <> rec b) Label l (Rule r) | getId l == getId r -> tag "rule" (f l) Label l a -> tag "label" (f l <> rec a) Atomic a -> tag "atomic" (rec a) - Rec n a -> tag "rec" (("var" .=. show n) <> rec a) - Not a -> tag "not" (recNot a) + Let ds a -> tag "let" (decls ds <> rec a) Rule r -> tag "rule" ("name" .=. show r) Var n -> tag "var" ("var" .=. show n) Succeed -> emptyTag "succeed" Fail -> emptyTag "fail" where asList s g = element s (map rec (collect g core)) - recNot = coreBuilder (const mempty) + decls ds = mconcat [ tag "decl" (("var" .=. show n) <> rec a) + | (n, a) <- ds + ] collect :: (a -> Maybe (a, a)) -> a -> [a] collect f = ($ []) . rec @@ -144,10 +145,6 @@ info <- toLabel xml r <- findRule info return (Label info (Rule r)) - buildRec x = do - s <- findAttribute "var" xml - i <- maybe (fail "var: not an int") return (readInt s) - return (Rec i x) buildVar = do s <- findAttribute "var" xml i <- maybe (fail "var: not an int") return (readInt s) @@ -166,12 +163,8 @@ , ("choice", buildChoice) , ("orelse", buildOrElse) , ("interleave", buildInterleave) - , ("many", comb1 Many) - , ("repeat", comb1 Repeat) , ("label", join2 comb1 buildLabel) , ("atomic", comb1 Atomic) - , ("rec", join2 comb1 buildRec) - , ("not", comb1 (Not . noLabels)) , ("rule", join2 comb0 buildRule) , ("var", join2 comb0 buildVar) , ("succeed", comb0 Succeed)
src/Ideas/Main/BlackBoxTests.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,10 +9,12 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: BlackBoxTests.hs 6537 2014-05-14 12:23:17Z bastiaan $ + module Ideas.Main.BlackBoxTests (blackBoxTests) where +import Control.Exception import Control.Monad -import Control.Monad.Error import Data.List import Ideas.Common.Utils (useFixedStdGen, snd3) import Ideas.Common.Utils.TestSuite @@ -26,59 +28,49 @@ -- Returns the number of tests performed blackBoxTests :: DomainReasoner -> String -> IO TestSuite blackBoxTests dr path = do - putStrLn ("Scanning " ++ path) -- analyse content xs0 <- getDirectoryContents path let (xml, xs1) = partition (".xml" `isSuffixOf`) xs0 (json, xs2) = partition (".json" `isSuffixOf`) xs1 - -- perform tests - ts1 <- forM json $ \x -> - doBlackBoxTest dr JSON (path ++ "/" ++ x) - ts2 <- forM xml $ \x -> - doBlackBoxTest dr XML (path ++ "/" ++ x) + xs3 = map (path </>) (filter ((/= ".") . take 1) xs2) -- recursively visit subdirectories - ts3 <- forM (filter ((/= ".") . take 1) xs2) $ \x -> do - let p = path ++ "/" ++ x - valid <- doesDirectoryExist p - if not valid - then return (return ()) - else liftM (suite $ "Directory " ++ simplerDirectory p) - (blackBoxTests dr p) - return $ - sequence_ (ts1 ++ ts2 ++ ts3) + 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 -> IO TestSuite -doBlackBoxTest dr format path = do - hSetBinaryMode stdout True - b <- doesFileExist expPath - return $ if not b - then warn $ expPath ++ " does not exist" - else assertIO (stripDirectoryPart path) $ do - -- Comparing output with expected output - (h1, h2, txt, expt) <- liftIO $ do - useFixedStdGen -- fix the random number generator - h1 <- openBinaryFile path ReadMode - txt <- hGetContents h1 - h2 <- openBinaryFile expPath ReadMode - expt <- hGetContents h2 - return (h1, h2, txt, expt) +doBlackBoxTest :: DomainReasoner -> DataFormat -> FilePath -> TestSuite +doBlackBoxTest dr format path = + assertMessageIO (stripDirectoryPart path) $ do + -- Comparing output with expected output + useFixedStdGen -- fix the random number generator + withFile path ReadMode $ \h1 -> do + hSetBinaryMode h1 True + txt <- hGetContents h1 out <- case format of - JSON -> liftM snd3 (processJSON False dr txt) - XML -> liftM snd3 (processXML dr Nothing txt) - -- Force evaluation of the result, to make sure that - -- all file handles are closed afterwards. - let result = out ~= expt - liftIO $ result `seq` (hClose h1 >> hClose h2 >> return result) - `catchError` - \_ -> return False + JSON -> liftM snd3 (processJSON Nothing False dr txt) + XML -> liftM snd3 (processXML Nothing dr Nothing txt) + withFile expPath ReadMode $ \h2 -> do + hSetBinaryMode h2 True + expt <- hGetContents h2 + -- Force evaluation of the result, to make sure that + -- all file handles are closed afterwards. + if out ~= expt then return mempty else return (message path) where expPath = baseOf path ++ ".exp" baseOf = reverse . drop 1 . dropWhile (/= '.') . reverse x ~= y = filterVersion x == filterVersion y -- compare line-based - filterVersion = - let p s = not (null s || "version" `isInfixOf` s) - in filter p . lines . filter (/= '\r') +filterVersion :: String -> [String] +filterVersion = + let p s = not (null s || "version" `isInfixOf` s) + in filter p . lines . filter (/= '\r') simplerDirectory :: String -> String simplerDirectory s @@ -88,6 +80,9 @@ stripDirectoryPart :: String -> String stripDirectoryPart = reverse . takeWhile (/= '/') . reverse + +(</>) :: FilePath -> FilePath -> FilePath +x </> y = x ++ "/" ++ y {- logicConfluence :: IO ()
src/Ideas/Main/Default.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,15 +12,22 @@ -- Main module for feedback services -- ----------------------------------------------------------------------------- -module Ideas.Main.Default (defaultMain, newDomainReasoner) where +-- $Id: Default.hs 6541 2014-05-14 18:44:36Z bastiaan $ +module Ideas.Main.Default + ( defaultMain, newDomainReasoner + -- extra exports + , Some(..), serviceList, metaServiceList, Service + , module Ideas.Service.DomainReasoner + ) where + import Control.Exception import Control.Monad import Data.IORef import Data.Maybe import Data.Time import Ideas.Common.Id -import Ideas.Common.Utils (useFixedStdGen) +import Ideas.Common.Utils (useFixedStdGen, Some(..)) import Ideas.Common.Utils.TestSuite import Ideas.Encoding.ModeJSON (processJSON) import Ideas.Encoding.ModeXML (processXML) @@ -31,6 +38,8 @@ import Ideas.Service.DomainReasoner import Ideas.Service.FeedbackScript.Analysis import Ideas.Service.Request +import Ideas.Service.ServiceList +import Ideas.Service.Types (Service) import Network.CGI import Prelude hiding (catch) import System.IO @@ -58,7 +67,7 @@ Just s -> return s (req, txt, ctp) <- liftIO $ process dr (Just cgiBin) input -- save logging action for later - unless (encoding req == Just HTMLEncoding) $ + when (useLogging req) $ liftIO $ writeIORef logRef $ logMessage req input txt addr startTime setHeader "Content-type" ctp @@ -87,14 +96,15 @@ Version -> putStrLn ("IDEAS, " ++ versionText) Help -> putStrLn helpText -- process input file - InputFile file -> do - input <- readFile file - (_, txt, _) <- process dr Nothing input - putStrLn txt + InputFile file -> + withBinaryFile file ReadMode $ \h -> do + input <- hGetContents h + (_, txt, _) <- process dr Nothing input + putStrLn txt -- blackbox tests Test dir -> do tests <- blackBoxTests dr dir - result <- runTestSuiteResult tests + result <- runTestSuiteResult True tests printSummary result -- generate documentation pages MakePages dir -> @@ -106,8 +116,8 @@ process :: DomainReasoner -> Maybe String -> String -> IO (Request, String, String) process dr cgiBin input = case discoverDataFormat input of - Just XML -> processXML dr cgiBin input - Just JSON -> processJSON (isJust cgiBin) dr input + Just XML -> processXML (Just 5) dr cgiBin input + Just JSON -> processJSON (Just 5) (isJust cgiBin) dr input _ -> fail "Invalid input" newDomainReasoner :: IsId a => a -> DomainReasoner
src/Ideas/Main/Documentation.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Manages links to information -- ----------------------------------------------------------------------------- +-- $Id: Documentation.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Main.Documentation (makeDocumentation) where import Control.Monad
src/Ideas/Main/LoggingDatabase.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- Facilities to create a log database -- ----------------------------------------------------------------------------- +-- $Id: LoggingDatabase.hs 6534 2014-05-14 06:02:03Z bastiaan $ + module Ideas.Main.LoggingDatabase (logMessage, logEnabled) where import Data.Time @@ -44,7 +46,7 @@ , toSql $ maybe "unknown" show (exerciseId req) , toSql $ fromMaybe "unknown" (source req) , toSql $ show (dataformat req) - , toSql $ maybe "unknown" show (encoding req) + , toSql $ show (encoding req) , toSql $ input , toSql $ output , toSql $ ipaddress @@ -55,7 +57,7 @@ -- close the connection to the database disconnect conn - `catch` \err -> do putStrLn $ "Error in logging to database: " ++ show err + `catchSql` \err -> do putStrLn $ "Error in logging to database: " ++ show err {- -- | Log table schema
src/Ideas/Main/Options.hs view
@@ -1,5 +1,5 @@ ---------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,7 +11,7 @@ -- Options and command-line flags for services -- ----------------------------------------------------------------------------- --- $Id: Options.hs 5781 2013-06-03 07:11:51Z bastiaan $ +-- $Id: Options.hs 6517 2014-05-06 16:01:59Z bastiaan $ module Ideas.Main.Options ( Flag(..), getFlags @@ -33,7 +33,7 @@ header :: String header = "IDEAS: Intelligent Domain-specific Exercise Assistants\n" ++ - "Copyright 2013, Open Universiteit Nederland\n" ++ + "Copyright 2014, Open Universiteit Nederland\n" ++ versionText ++ "\n\nUsage: ideas [OPTION] (by default, CGI protocol)\n" ++ "\nOptions:"
src/Ideas/Main/Revision.hs view
@@ -2,10 +2,10 @@ module Ideas.Main.Revision where ideasVersion :: String-ideasVersion = "1.1"+ideasVersion = "1.2" ideasRevision :: Int-ideasRevision = 5787+ideasRevision = 6534 ideasLastChanged :: String-ideasLastChanged = "za, 08 jun 2013"+ideasLastChanged = "wo, 14 mei 2014"
src/Ideas/Service/BasicServices.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,11 +9,13 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: BasicServices.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.BasicServices ( -- * Basic Services stepsremaining, findbuggyrules, ready, allfirsts, derivation - , onefirst, applicable, allapplications, apply, generate, generateWith - , StepInfo, exampleDerivations + , onefirst, applicable, allapplications, apply, generate, create + , StepInfo, exampleDerivations, recognizeRule ) where import Control.Monad @@ -25,16 +27,23 @@ import Ideas.Service.State import System.Random import qualified Ideas.Common.Classes as Apply - -generate :: Exercise a -> Maybe Difficulty -> IO (State a) -generate ex = liftM (emptyState ex) . randomTerm ex +import qualified Ideas.Common.Library as Library -generateWith :: StdGen -> Exercise a -> Maybe Difficulty -> Either String (State a) -generateWith rng ex md = - case randomTermWith rng ex md of +generate :: StdGen -> Exercise a -> Maybe Difficulty -> Either String (State a) +generate rng ex md = + case randomTerm rng ex md of Just a -> return (emptyState ex a) - Nothing -> fail "No random term" + Nothing -> Left "No random term" +create :: Exercise a -> String -> Either String (State a) +create ex input = + case parser ex input of + Left err -> Left err + Right a + | evalPredicate (Library.ready ex) a -> Left "Is ready" + | evalPredicate (Library.suitable ex) a -> Right (emptyState ex a) + | otherwise -> Left "Not suitable" + -- TODO: add a location to each step derivation :: Maybe StrategyConfiguration -> State a -> Either String (Derivation (Rule (Context a), Environment) (Context a)) derivation mcfg state = @@ -75,7 +84,7 @@ | otherwise = let trees = map tree ps tree p = cutOnStep (justMajor . lastStepInPrefix) - (prefixTree False p (stateContext state)) + (prefixTree (stateContext state) p) f ((r1, _, _), _) ((r2, _, _), _) = ruleOrdering (exercise state) r1 r2 justMajor = maybe False isMajor @@ -169,6 +178,18 @@ ] where ex = exercise state + +-- Recognize a rule at (possibly multiple) locations +recognizeRule :: Exercise a -> Rule (Context a) -> Context a -> Context a -> [(Location, Environment)] +recognizeRule ex r ca cb = rec (top ca) + where + final = addTransRecognizer (similarity ex) r + rec x = do + -- here + as <- recognizeAll final x cb + return (location x, as) + `mplus` -- or there + concatMap rec (downs x) exampleDerivations :: Exercise a -> Either String [Derivation (Rule (Context a), Environment) (Context a)] exampleDerivations ex = mapM (derivation Nothing . emptyState ex . snd) (examples ex)
src/Ideas/Service/Diagnose.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,16 +12,21 @@ -- Diagnose a term submitted by a student -- ----------------------------------------------------------------------------- +-- $Id: Diagnose.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.Diagnose ( Diagnosis(..), diagnose, restartIfNeeded, newState + , difference, differenceEqual ) where +import Data.Function import Data.List (sortBy) import Data.Maybe import Ideas.Common.Library hiding (ready) import Ideas.Service.BasicServices hiding (apply) import Ideas.Service.State import Ideas.Service.Types +import qualified Ideas.Common.Rewriting.Difference as Diff ---------------------------------------------------------------- -- Result types for diagnose service @@ -30,20 +35,26 @@ = Buggy Environment (Rule (Context a)) -- | Missing -- | IncorrectPart [a] - | NotEquivalent + | NotEquivalent String | Similar Bool (State a) + | WrongRule Bool (State a) (Maybe (Rule (Context a))) | Expected Bool (State a) (Rule (Context a)) | Detour Bool (State a) Environment (Rule (Context a)) | Correct Bool (State a) + | Unknown Bool (State a) -- Added for the FP domain, to indicate that no + -- diagnose is possible (i.e., QC gave up) instance Show (Diagnosis a) where show diagnosis = case diagnosis of - Buggy as r -> "Buggy rule " ++ show (show r) ++ showArgs as + Buggy as r -> "Buggy rule " ++ show (show r) ++ showArgs as + Unknown _ _ -> "Unknown step" -- Missing -> "Missing solutions" -- IncorrectPart xs -> "Incorrect parts (" ++ show (length xs) ++ " items)" - NotEquivalent -> "Unknown mistake" + NotEquivalent s -> if null s then "Unknown mistake" else s Similar _ _ -> "Very similar" + WrongRule _ _ mr -> "Wrong rule selected" ++ + maybe "" (\r -> ", " ++ showId r ++ "recognized") mr Expected _ _ r -> "Rule " ++ show (show r) ++ ", expected by strategy" Detour _ _ _ r -> "Rule " ++ show (show r) ++ ", not following strategy" Correct _ _ -> "Unknown step" @@ -56,24 +67,37 @@ newState diagnosis = case diagnosis of Buggy _ _ -> Nothing - NotEquivalent -> 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 ---------------------------------------------------------------- -- The diagnose service -diagnose :: State a -> Context a -> Diagnosis a -diagnose state new +diagnose :: State a -> Context a -> Maybe Id -> Diagnosis a +diagnose state new motivationId -- Is the submitted term equivalent? | not (equivalence ex (stateContext state) new) = -- Is the rule used discoverable by trying all known buggy rules? - case discovered True of + case discovered True Nothing of Just (r, as) -> Buggy as r -- report the buggy rule - Nothing -> NotEquivalent -- compareParts state new + Nothing -> NotEquivalent "" -- compareParts state new + -- Is the used rule that is submitted applied correctly? + | isJust motivationId && isNothing (discovered False motivationId) = + case discovered False Nothing of -- search for a "sound" rule + Just (r, _) -> WrongRule (ready state) state (Just r) + Nothing -> + case discovered True Nothing of -- search for buggy rule + Just (r, as) -> + Buggy as r -- report the buggy rule + Nothing -> + WrongRule (ready state) state Nothing + -- Was the submitted term expected by the strategy? | isJust expected = -- If yes, return new state and rule @@ -81,11 +105,13 @@ in Expected (ready ns) ns r -- Is the submitted term (very) similar to the previous one? + -- (this check is performed after "expected by strategy". TODO: fix + -- granularity of some math rules) | similar = Similar (ready state) state -- Is the rule used discoverable by trying all known rules? | otherwise = - case discovered False of + case discovered False Nothing of Just (r, as) -> -- If yes, report the found rule as a detour Detour (ready restarted) restarted as r Nothing -> -- If not, we give up @@ -100,10 +126,11 @@ p (_, ns) = similarity ex new (stateContext ns) -- use rule recognizer? listToMaybe (filter p xs) - discovered searchForBuggy = listToMaybe + discovered searchForBuggy searchForRule = listToMaybe [ (r, env) | r <- sortBy (ruleOrdering ex) (ruleset ex) , isBuggy r == searchForBuggy + , maybe True (`elem` getId r:ruleSiblings r) searchForRule , (_, env) <- recognizeRule ex r sub1 sub2 ] where @@ -133,20 +160,36 @@ f (Left (Left (as, r))) = Buggy as r -- f (Left (Right (Left ()))) = Missing -- f (Left (Right (Right (Left xs)))) = IncorrectPart xs - f (Left (Right ())) = NotEquivalent + f (Left (Right (Left s))) = NotEquivalent s + f (Left (Right (Right (b, s, mr)))) = WrongRule b s mr f (Right (Left (b, s))) = Similar b s f (Right (Right (Left (b, s, r)))) = Expected b s r f (Right (Right (Right (Left (b, s, as, r))))) = Detour b s as r - f (Right (Right (Right (Right (b, s))))) = Correct b s + f (Right (Right (Right (Right (Left (b, s)))))) = Correct b s + f (Right (Right (Right (Right (Right (b, s)))))) = Unknown b s g (Buggy as r) = Left (Left (as, r)) -- g Missing = Left (Right (Left ())) -- g (IncorrectPart xs) = Left (Right (Right (Left xs))) - g NotEquivalent = Left (Right ()) + g (NotEquivalent s) = Left (Right (Left s)) + g (WrongRule b s mr) = Left (Right (Right (b, s, mr))) g (Similar b s) = Right (Left (b, s)) g (Expected b s r) = Right (Right (Left (b, s, r))) g (Detour b s as r) = Right (Right (Right (Left (b, s, as, r)))) - g (Correct b s) = Right (Right (Right (Right (b, s)))) + g (Correct b s) = Right (Right (Right (Right (Left (b, s))))) + g (Unknown b s) = Right (Right (Right (Right (Right (b, s))))) + +difference :: Exercise a -> a -> a -> Maybe (a, a) +difference ex a b = do + v <- hasTermView ex + Diff.differenceWith v a b + +-- Used by the FP tutor +differenceEqual :: Exercise a -> a -> a -> Maybe (a, a) +differenceEqual ex a b = do + v <- hasTermView ex + let simpleEq = equivalence ex `on` inContext ex + Diff.differenceEqualWith v simpleEq a b ---------------------------------------------------------------- -- Compare answer sets (and search for missing parts/incorrect parts)
src/Ideas/Service/DomainReasoner.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: DomainReasoner.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.DomainReasoner ( DomainReasoner(..) , exercisesSorted, servicesSorted
src/Ideas/Service/FeedbackScript/Analysis.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Analysis of a feedbackscript -- ----------------------------------------------------------------------------- +-- $Id: Analysis.hs 6540 2014-05-14 15:13:00Z bastiaan $ + module Ideas.Service.FeedbackScript.Analysis ( -- Analysis functions makeScriptFor, parseAndAnalyzeScript, analyzeScript @@ -18,8 +20,6 @@ , Message(..) ) where -import Control.Monad -import Control.Monad.Error import Data.Either import Data.List import Ideas.Common.Library @@ -44,11 +44,11 @@ parseAndAnalyzeScript dr file = do putStrLn $ "Parsing " ++ show file script <- parseScript file - let sups = [ a | Supports as <- scriptDecls script, a <- as ] - exs <- forM sups $ \a -> - liftM Right (findExercise dr a) - `catchError` \_ -> return $ Left $ UnknownExercise a - + let exs = [ maybe unknown Right (findExercise dr a) + | Supports as <- scriptDecls script + , a <- as + , let unknown = Left (UnknownExercise a) + ] let ms = lefts exs ++ analyzeScript (rights exs) script putStrLn $ unlines $ map show ms putStrLn $ "(errors: " ++ show (length ms) ++ ")"
src/Ideas/Service/FeedbackScript/Parser.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,12 +11,14 @@ -- Simple parser for feedback scripts -- ----------------------------------------------------------------------------- +-- $Id: Parser.hs 6541 2014-05-14 18:44:36Z bastiaan $ + module Ideas.Service.FeedbackScript.Parser ( parseScript, parseScriptSafe, Script ) where import Control.Exception hiding (try) -import Control.Monad.Error +import Control.Monad import Data.Char import Data.List import Data.Monoid @@ -29,7 +31,10 @@ -- returns the empty script if something goes wrong parseScriptSafe :: FilePath -> IO Script -parseScriptSafe file = parseScript file `mplus` return mempty +parseScriptSafe file = parseScript file `catch` handler + where + handler :: SomeException -> IO Script + handler _ = return mempty -- chases all included script files parseScript :: FilePath -> IO Script @@ -97,6 +102,7 @@ condition = choice [ CondRef <$> lexeme attribute , RecognizedIs <$ lexString "recognize" <*> identifier + , MotivationIs <$ lexString "motivation" <*> identifier , CondConst True <$ lexString "true" , CondConst False <$ lexString "false" , CondNot <$ lexString "not" <*> condition
src/Ideas/Service/FeedbackScript/Run.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Run a feedbackscript -- ----------------------------------------------------------------------------- +-- $Id: Run.hs 6536 2014-05-14 11:29:55Z bastiaan $ + module Ideas.Service.FeedbackScript.Run ( Script , Environment(..), newEnvironment @@ -34,6 +36,7 @@ { oldReady :: Bool , expected :: Maybe (Rule (Context a)) , recognized :: Maybe (Rule (Context a)) + , motivation :: Maybe (Rule (Context a)) , actives :: Maybe [LabelInfo] , diffPair :: Maybe (String, String) , before :: Maybe Term @@ -41,15 +44,16 @@ , afterText :: Maybe String } -newEnvironment :: State a -> Environment a -newEnvironment st = newEnvironmentFor st next +newEnvironment :: State a -> Maybe (Rule (Context a)) -> Environment a +newEnvironment st motivationRule = newEnvironmentFor st motivationRule next where next = either (const Nothing) Just (onefirst st) -newEnvironmentFor :: State a -> Maybe ((Rule (Context a), b, c), State a) -> Environment a -newEnvironmentFor st next = Env +newEnvironmentFor :: State a -> Maybe (Rule (Context a)) -> Maybe ((Rule (Context a), b, c), State a) -> Environment a +newEnvironmentFor st motivationRule next = Env { oldReady = ready st , expected = fmap (\((x,_,_),_) -> x) next + , motivation = motivationRule , recognized = Nothing , actives = listToMaybe (stateLabels st) , diffPair = Nothing @@ -83,17 +87,22 @@ | a == beforeId = fmap TextTerm (before env) | a == afterId = fmap TextTerm (after env) | a == afterTextId = fmap TextString (afterText env) + | a == motivationId = fmap (findIdRef . getId) (motivation env) | otherwise = findRef (==a) unref t = Just t evalBool :: Condition -> Bool evalBool (RecognizedIs a) = maybe False (eqId a . getId) (recognized env) + evalBool (MotivationIs a) = maybe False (eqId a . getId) (motivation env) evalBool (CondNot c) = not (evalBool c) evalBool (CondConst b) = b evalBool (CondRef a) - | a == oldreadyId = oldReady env - | a == hasexpectedId = isJust (expected env) - | otherwise = False + | a == oldreadyId = oldReady env + | a == hasexpectedId = isJust (expected env) + | a == hasrecognizedId = isJust (recognized env) + | a == hasmotivationId = isJust (motivation env) + | a == recognizedbuggyId = maybe False isBuggy (recognized env) + | otherwise = False namespaces = nub $ mempty : [ a | NameSpace as <- scriptDecls script, a <- as ] @@ -120,49 +129,52 @@ feedbackDiagnosis :: Diagnosis a -> Environment a -> Script -> Text feedbackDiagnosis diagnosis env = case diagnosis of - Buggy _ r -> makeWrong "buggy" env {recognized = Just r} - NotEquivalent -> makeWrong "noteq" env - Expected _ _ r -> makeOk "ok" env {recognized = Just r} - Similar _ _ -> makeOk "same" env - Detour _ _ _ r -> makeOk "detour" env {recognized = Just r} - Correct _ _ -> makeOk "unknown" env + Buggy _ r -> makeWrong "buggy" env {recognized = Just r} + 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 + Unknown _ _ -> makeOk "unknown" env where makeOk = makeDefault "Well done!" makeWrong = makeDefault "This is incorrect." + makeNotEq s = if null s then makeWrong else makeDefault s makeDefault dt s e = fromMaybe (TextString dt) . make (newId s) e feedbackHint :: Id -> Environment a -> Script -> Text feedbackHint feedbackId env script = fromMaybe (defaultHint env script) $ make feedbackId env script -feedbackHints :: Id -> [((Rule (Context a), b, c), State a)] -> State a -> Script -> [Text] -feedbackHints feedbackId nexts state script = +feedbackHints :: Id -> [((Rule (Context a), b, c), State a)] -> State a -> Maybe (Rule (Context a)) -> Script -> [Text] +feedbackHints feedbackId nexts state motivationRule script = map (\env -> fromMaybe (defaultHint env script) $ make feedbackId env script) envs where - envs = map (newEnvironmentFor state . Just) nexts + envs = map (newEnvironmentFor state motivationRule . Just) nexts defaultHint :: Environment a -> Script -> Text defaultHint env script = makeText $ case expected env of Just r -> ruleToString env script r - Nothing -> "Sorry, not hint available." + Nothing -> "Sorry, no hint available." make :: Id -> Environment a -> Script -> Maybe Text make feedbackId env script = toText env script (TextRef feedbackId) feedbackIds :: [Id] feedbackIds = map newId - ["same", "noteq", "unknown", "ok", "buggy", "detour", "hint", "step", "label"] + ["same", "noteq", "unknown", "ok", "buggy", "detour", "wrongrule", "hint", "step", "label"] attributeIds :: [Id] attributeIds = - [expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId] + [expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId, motivationId] conditionIds :: [Id] -conditionIds = [oldreadyId, hasexpectedId] +conditionIds = [oldreadyId, hasexpectedId, hasrecognizedId, hasmotivationId, recognizedbuggyId] -expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId :: Id +expectedId, recognizedId, diffbeforeId, diffafterId, beforeId, afterId, afterTextId, motivationId :: Id expectedId = newId "expected" recognizedId = newId "recognized" diffbeforeId = newId "diffbefore" @@ -170,7 +182,11 @@ beforeId = newId "before" afterId = newId "after" afterTextId = newId "aftertext" +motivationId = newId "motivation" -oldreadyId, hasexpectedId :: Id -oldreadyId = newId "oldready" -hasexpectedId = newId "hasexpected"+oldreadyId, hasexpectedId, hasrecognizedId, hasmotivationId, recognizedbuggyId :: Id +oldreadyId = newId "oldready" +hasexpectedId = newId "hasexpected" +hasrecognizedId = newId "hasrecognized" +hasmotivationId = newId "hasmotivation" +recognizedbuggyId = newId "recognizedbuggy"
src/Ideas/Service/FeedbackScript/Syntax.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Abstract syntax for feedback scripts, and pretty-printer (Show instance) -- ----------------------------------------------------------------------------- +-- $Id: Syntax.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.FeedbackScript.Syntax ( Script, makeScript, scriptDecls, makeText, textItems , Decl(..), DeclType(..), Text(..), Condition(..), includes @@ -47,6 +49,7 @@ data Condition = RecognizedIs Id + | MotivationIs Id | CondNot Condition | CondConst Bool | CondRef Id @@ -54,7 +57,7 @@ makeText :: String -> Text makeText s = case words s of [] -> TextEmpty - xs -> TextString (combineList xs) + xs -> TextString (unwords xs) feedbackDecl, textForIdDecl :: HasId a => a -> Text -> Decl feedbackDecl a = Simple Feedback [getId a] @@ -86,6 +89,7 @@ instance Show Condition where show (RecognizedIs a) = "recognize " ++ show a + show (MotivationIs a) = "motivation " ++ show a show (CondNot c) = "not " ++ show c show (CondConst b) = map toLower (show b) show (CondRef a) = '@' : show a @@ -123,9 +127,9 @@ rec TextEmpty = id rec a = (a:) -combineList :: [String] -> String -combineList = foldr combine [] - +-- Combine two strings by inserting a space in between (unless one of the +-- strings is empty, or when the second string starts with an interpunction +-- symbol). combine :: String -> String -> String combine a b | null a = b
src/Ideas/Service/FeedbackText.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: FeedbackText.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.FeedbackText ( Message, accept, text , onefirsttext, submittext, derivationtext, feedbacktext @@ -36,7 +38,7 @@ derivationtext :: Script -> State a -> Either String (Derivation String (Context a)) derivationtext script state = - let f = ruleToString (newEnvironment state) script . fst + let f = ruleToString (newEnvironment state Nothing) script . fst in right (mapFirst f) (derivation Nothing state) onefirsttext :: Script -> State a -> Maybe String -> (Message, Maybe (State a)) @@ -50,7 +52,7 @@ else "step" ex = exercise old next = either (const Nothing) Just (onefirst old) - env = (newEnvironment old) + env = (newEnvironment old Nothing) { diffPair = do new <- fmap snd next oldC <- fromContext (stateContext old) @@ -66,25 +68,28 @@ submittext script old input = case parser ex input of Left msg -> (M (Just False) (TextString msg), old) - Right a -> feedbacktext script old (inContext ex a) + Right a -> feedbacktext script old (inContext ex a) Nothing where ex = exercise old -feedbacktext :: Script -> State a -> Context a -> (Message, State a) -feedbacktext script old new = +feedbacktext :: Script -> State a -> Context a -> Maybe Id -> (Message, State a) +feedbacktext script old new motivationId = case diagnosis of - Buggy _ _ -> (msg False, old) - NotEquivalent -> (msg False, old) - Expected _ s _ -> (msg True, s) - Similar _ s -> (msg True, s) - Detour _ s _ _ -> (msg True, s) - Correct _ s -> (msg False, s) + Buggy _ _ -> (msg False, old) + NotEquivalent _ -> (msg False, old) + Expected _ s _ -> (msg True, s) + WrongRule _ s _ -> (msg True, s) + Similar _ s -> (msg True, s) + Detour _ s _ _ -> (msg True, s) + Correct _ s -> (msg False, s) + Unknown _ s -> (msg False, s) where - diagnosis = diagnose old new + diagnosis = diagnose old new motivationId output = feedbackDiagnosis diagnosis env script msg b = M (Just b) output - ex = exercise old - env = (newEnvironment old) + ex = exercise old + motivationRule = motivationId >>= getRule ex + env = (newEnvironment old motivationRule) { diffPair = do oldTerm <- fromContext (stateContext old) newTerm <- fromContext new
src/Ideas/Service/ProblemDecomposition.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: ProblemDecomposition.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.ProblemDecomposition ( problemDecomposition, Reply(..) ) where @@ -33,7 +35,7 @@ witnesses = filter (similarity ex answeredTerm . fst) $ take 1 answers (newCtx, newPrefix) = head witnesses newLocation = nextTaskLocation (strategy ex) sloc $ - fromMaybe topId $ nextMajorForPrefix newPrefix newCtx + fromMaybe topId $ nextMajorForPrefix newCtx newPrefix newState = makeState ex [newPrefix] newCtx _ -> Right $ Incorrect isEquiv newLocation expState arguments @@ -45,21 +47,20 @@ (loc, arguments) = fromMaybe (topId, mempty) $ firstMajorInPrefix prefix pref where - ex = exercise state - topId = getId (strategy ex) - sloc = fromMaybe topId msloc - answers = runPrefixLocation sloc prefix requestedTerm - requestedTerm = stateContext state - prefix = case statePrefixes state of - [] -> emptyPrefix (strategy ex) - hd:_ -> hd + ex = exercise state + topId = getId (strategy ex) + sloc = fromMaybe topId msloc + answers = runPrefixLocation sloc (stateContext state) prefix + prefix = case statePrefixes state of + [] -> emptyPrefix (strategy ex) (stateContext state) + hd:_ -> hd -- | Continue with a prefix until a certain strategy location is reached. At least one -- major rule should have been executed -runPrefixLocation :: Id -> Prefix a -> a -> [(a, Prefix a)] -runPrefixLocation loc p0 = - concatMap (checkPair . f) . derivations . - cutOnStep (stop . lastStepInPrefix) . prefixTree False p0 +runPrefixLocation :: Id -> a -> Prefix a -> [(a, Prefix a)] +runPrefixLocation loc a0 p0 = + concatMap (checkPair . f) $ derivations $ + cutOnStep (stop . lastStepInPrefix) $ prefixTree a0 p0 where f d = (lastTerm d, fromMaybe p0 (lastStep d)) stop (Just (Exit info)) = getId info == loc @@ -67,7 +68,7 @@ checkPair result@(a, p) | null rules = [result] - | all isMinor rules = runPrefixLocation loc p a + | all isMinor rules = runPrefixLocation loc a p | otherwise = [result] where rules = stepsToRules $ drop (length $ prefixToSteps p0) $ prefixToSteps p @@ -83,9 +84,9 @@ _:rest -> rec rest [] -> Nothing -nextMajorForPrefix :: Prefix a -> a -> Maybe Id -nextMajorForPrefix p0 a = do - (_, p1) <- listToMaybe $ runPrefixMajor p0 a +nextMajorForPrefix :: a -> Prefix a -> Maybe Id +nextMajorForPrefix a p0 = do + (_, p1) <- listToMaybe $ runPrefixMajor a p0 rec (reverse (prefixToSteps p1)) where rec [] = Nothing @@ -94,9 +95,9 @@ rec (_:rest) = rec rest -- Copied from TypedAbstractService: clean me up -runPrefixMajor :: Prefix a -> a -> [(a, Prefix a)] -runPrefixMajor p0 = - map f . derivations . cutOnStep (stop . lastStepInPrefix) . prefixTree False p0 +runPrefixMajor :: a -> Prefix a -> [(a, Prefix a)] +runPrefixMajor a p0 = + map f $ derivations $ cutOnStep (stop . lastStepInPrefix) $ prefixTree a p0 where f d = (lastTerm d, fromMaybe p0 (lastStep d)) stop = maybe False isMajor
src/Ideas/Service/Request.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,25 +9,61 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Request.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.Request where import Data.Char +import Data.List import Ideas.Common.Library hiding (exerciseId) +import Ideas.Common.Utils data Request = Request { service :: String , exerciseId :: Maybe Id , source :: Maybe String , dataformat :: DataFormat - , encoding :: Maybe Encoding + , encoding :: [Encoding] } data DataFormat = XML | JSON deriving Show -- needed for LoggingDatabase -data Encoding = OpenMath | StringEncoding | HTMLEncoding - deriving (Show, Eq) -- 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 + 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" + +htmlOutput :: Request -> Bool +htmlOutput = (EncHTML `elem`) . encoding + +compactOutput :: Request -> Bool +compactOutput = compactOutputDefault True + +compactOutputDefault :: Bool -> Request -> Bool +compactOutputDefault b req = + let xs = encoding req + in case (EncCompact `elem` xs, EncPretty `elem` xs) of + (True, False) -> True + (False, True) -> False + _ -> b + +useOpenMath :: Request -> Bool +useOpenMath = (EncString `notElem`) . encoding + +useLogging :: Request -> Bool +useLogging = (EncHTML `notElem`) . encoding + discoverDataFormat :: Monad m => String -> m DataFormat discoverDataFormat xs = case dropWhile isSpace xs of @@ -35,10 +71,12 @@ '{':_ -> return JSON _ -> fail "Unknown data format" -readEncoding :: Monad m => String -> m Encoding -readEncoding xs = - case map toLower xs of - "openmath" -> return OpenMath - "string" -> return StringEncoding - "html" -> return HTMLEncoding - _ -> fail $ "Invalid encoding: " ++ xs+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 s = fail $ "Invalid encoding: " ++ s
src/Ideas/Service/ServiceList.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,9 +9,13 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: ServiceList.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.ServiceList (serviceList, metaServiceList) where +import Ideas.Common.ExerciseTests import Ideas.Common.Library hiding (apply, applicable, derivation, ready) +import Ideas.Common.Utils.TestSuite import Ideas.Service.BasicServices import Ideas.Service.DomainReasoner import Ideas.Service.FeedbackText @@ -29,7 +33,7 @@ -- basic services [ derivationS, allfirstsS, onefirstS, readyS , stepsremainingS, allapplicationsS - , applyS, generateS, applicableS + , applyS, generateS, createS, applicableS , examplesS, submitS, diagnoseS , findbuggyrulesS, problemdecompositionS -- textual services @@ -41,7 +45,7 @@ metaServiceList dr = [ indexS dr, servicelistS dr, serviceinfoS dr, exerciselistS dr , rulelistS, ruleinfoS, rulesinfoS, strategyinfoS, exerciseinfoS - , stateinfoS, examplederivationsS + , stateinfoS, examplederivationsS, testreportS ] ------------------------------------------------------ @@ -110,8 +114,14 @@ generateS = makeService "basic.generate" "Given an exercise code and a difficulty level (optional), this service \ \returns an initial state with a freshly generated expression." $ - generateWith ::: typed + generate ::: typed +createS :: Service +createS = makeService "basic.create" + "Given an expression, this service \ + \returns an initial state with the original given expression." $ + create ::: typed + examplesS :: Service examplesS = makeService "basic.examples" "This services returns a list of example expresssions that can be solved \ @@ -247,4 +257,9 @@ examplederivationsS :: Service examplederivationsS = makeService "meta.examplederivations" - "Show example derivations" $ exampleDerivations ::: typed+ "Show example derivations" $ exampleDerivations ::: typed + +testreportS :: Service +testreportS = makeService "meta.testreport" + "Show test report for an exercise." $ + (\stdgen -> runTestSuiteResult False . exerciseTestSuite stdgen) ::: typed
src/Ideas/Service/State.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- derivation. -- ----------------------------------------------------------------------------- +-- $Id: State.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.State ( -- * Exercise state State, makeState, makeNoState, emptyStateContext, emptyState @@ -22,7 +24,6 @@ import Data.Maybe import Ideas.Common.Library import Ideas.Common.Strategy.Abstract (LabelInfo) -import Ideas.Common.Strategy.Prefix (activeLabels) data State a = State { exercise :: Exercise a @@ -34,7 +35,7 @@ show s = unlines $ "State {" : map (" "++) xs ++ ["}"] where xs = [ "exercise = " ++ showId s - , "prefix = " ++ intercalate ";" (map show (statePrefixes s)) + , "prefix = " ++ intercalate ";" (map showPrefix (statePrefixes s)) , "steps = " ++ intercalate ";" (map (show . prefixToSteps) (statePrefixes s)) , "term = " ++ prettyPrinterContext (exercise s) (stateContext s) ] @@ -69,9 +70,9 @@ makeNoState = flip makeState [] emptyStateContext :: Exercise a -> Context a -> State a -emptyStateContext ex = makeState ex [pr] - where - pr = emptyPrefix (strategy ex) +emptyStateContext ex ca = + let pr = emptyPrefix (strategy ex) ca + in makeState ex [pr] ca emptyState :: Exercise a -> a -> State a emptyState ex = emptyStateContext ex . inContext ex
src/Ideas/Service/Submit.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,10 +12,13 @@ -- Diagnose a term submitted by a student. Deprecated (see diagnose service). -- ----------------------------------------------------------------------------- +-- $Id: Submit.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.Submit ( submit, Result(..) ) where +import Data.Maybe import Ideas.Common.Library import Ideas.Service.Diagnose (Diagnosis, diagnose) import Ideas.Service.State @@ -24,7 +27,7 @@ -- Note that in the typed setting there is no syntax error data Result a = Buggy [Rule (Context a)] - | NotEquivalent + | NotEquivalent String | Ok [Rule (Context a)] (State a) -- equivalent | Detour [Rule (Context a)] (State a) -- equivalent | Unknown (State a) -- equivalent @@ -32,29 +35,31 @@ fromDiagnose :: Diagnosis a -> Result a fromDiagnose diagnosis = case diagnosis of - Diagnose.Buggy _ r -> Buggy [r] - Diagnose.NotEquivalent -> NotEquivalent - Diagnose.Similar _ s -> Ok [] s - Diagnose.Expected _ s r -> Ok [r] s - Diagnose.Detour _ s _ r -> Detour [r] s - Diagnose.Correct _ s -> Unknown s + Diagnose.Buggy _ r -> Buggy [r] + Diagnose.NotEquivalent s -> NotEquivalent s + Diagnose.Similar _ s -> Ok [] s + Diagnose.Expected _ s r -> Ok [r] s + Diagnose.WrongRule _ s mr -> Ok (maybeToList mr) s + Diagnose.Detour _ s _ r -> Detour [r] s + Diagnose.Correct _ s -> Unknown s + Diagnose.Unknown _ s -> Unknown s -- Diagnose.Missing -> NotEquivalent -- Diagnose.IncorrectPart _ -> NotEquivalent submit :: State a -> Context a -> Result a -submit state = fromDiagnose . diagnose state +submit state ctx = fromDiagnose (diagnose state ctx Nothing) instance Typed a (Result a) where typed = Tag "Result" (Iso (f <-> g) typed) where f (Left rs) = Buggy rs - f (Right (Left ())) = NotEquivalent + f (Right (Left s)) = NotEquivalent s f (Right (Right (Left (rs, s)))) = Ok rs s f (Right (Right (Right (Left (rs, s))))) = Detour rs s f (Right (Right (Right (Right s)))) = Unknown s - g (Buggy rs) = Left rs - g (NotEquivalent) = Right (Left ()) - g (Ok rs s) = Right (Right (Left (rs, s))) - g (Detour rs s) = Right (Right (Right (Left (rs, s)))) - g (Unknown s) = Right (Right (Right (Right s)))+ g (Buggy rs) = Left rs + g (NotEquivalent s) = Right (Left s) + g (Ok rs s) = Right (Right (Left (rs, s))) + g (Detour rs s) = Right (Right (Right (Left (rs, s)))) + g (Unknown s) = Right (Right (Right (Right s)))
src/Ideas/Service/Types.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, Rank2Types, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Types.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Service.Types ( -- * Services Service, makeService, deprecate @@ -29,6 +31,7 @@ import Ideas.Service.FeedbackScript.Syntax import Ideas.Service.State import System.Random +import qualified Ideas.Common.Utils.TestSuite as TestSuite ----------------------------------------------------------------------------- -- Services @@ -90,6 +93,7 @@ equal SomeExercise SomeExercise = Just id equal Text Text = Just id equal StdGen StdGen = Just id + equal Result Result = Just id equal _ _ = Nothing infixr 5 :|: @@ -110,6 +114,8 @@ Iso :: Isomorphism t1 t2 -> TypeRep f t1 -> TypeRep f t2 -- Function type (:->) :: TypeRep f t1 -> TypeRep f t2 -> TypeRep f (t1 -> t2) + -- Input/output + IO :: TypeRep f t -> TypeRep f (IO t) -- Special annotations Tag :: String -> TypeRep f t1 -> TypeRep f t1 -- Type constructors @@ -136,6 +142,7 @@ Environment :: Const a Environment Text :: Const a Text StdGen :: Const a StdGen + Result :: Const a TestSuite.Result SomeExercise :: Const a (Some Exercise) -- basic types Bool :: Const a Bool @@ -151,6 +158,7 @@ instance ShowF f => Show (TypeRep f t) where show (Iso _ t) = show t show (t1 :-> t2) = show t1 ++ " -> " ++ show t2 + show (IO t) = show t show t@(Pair _ _) = showTuple t show (t1 :|: t2) = show t1 ++ " | " ++ show t2 show (Tag s _) = s @@ -163,6 +171,7 @@ case tp of Iso iso t -> show (to iso val ::: t) _ :-> _ -> "<<function>>" + IO _ -> "<<io>>" Tag _ t -> show (val ::: t) List t -> showAsList (map (show . (::: t)) val) Pair t1 t2 -> "(" ++ show (fst val ::: t1) ++ @@ -191,6 +200,7 @@ Environment -> show val Text -> show val StdGen -> show val + Result -> show val Bool -> map toLower (show val) Int -> show val String -> val @@ -212,6 +222,7 @@ showF Environment = "Environment" showF Text = "TextMessage" showF StdGen = "StdGen" + showF Result = "TestSuiteResult" showF SomeExercise = "Exercise" showF Bool = "Bool" showF Int = "Int" @@ -266,6 +277,9 @@ instance Typed a StdGen where typed = Const StdGen +instance Typed a TestSuite.Result where + typed = Const Result + instance Typed a Difficulty where typed = Tag "Difficulty" (Iso (f <-> show) typed) where @@ -309,6 +323,9 @@ instance (Typed a t1, Typed a t2) => Typed a (t1 -> t2) where typed = typed :-> typed + +instance Typed a t => Typed a (IO t) where + typed = IO typed instance Typed a t => Typed a (Maybe t) where typed = Iso (f <-> g) (typed :|: Unit)
src/Ideas/Text/HTML.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,6 +12,8 @@ -- See http://www.w3.org/TR/html4/ -- ----------------------------------------------------------------------------- +-- $Id: HTML.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.HTML ( HTMLPage, HTMLBuilder , addCSS, addScript, showHTML @@ -150,7 +152,7 @@ -- A simple XML highlighter highlightXML :: Bool -> XML -> HTMLBuilder highlightXML nice - | nice = builder . highlight . makeXML "pre" . string . showXML + | nice = builder . highlight . makeXML "pre" . string . show | otherwise = builder . highlight . makeXML "tt" . string . compactXML where highlight :: XML -> XML
src/Ideas/Text/JSON.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,21 +12,25 @@ -- JSON. JSON is a lightweight alternative for XML. -- ----------------------------------------------------------------------------- +-- $Id: JSON.hs 6541 2014-05-14 18:44:36Z bastiaan $ + module Ideas.Text.JSON ( JSON(..), Key, Number(..) -- types - , InJSON(..) -- type class" + , InJSON(..) -- type class , lookupM - , parseJSON, showCompact, showPretty -- parser and pretty-printers + , parseJSON, compactJSON -- parser and pretty-printers , jsonRPC, RPCHandler, propEncoding ) where import Control.Exception -import Control.Monad.Error -import Data.List (intercalate) +import Control.Monad +import Data.List (intersperse) import Data.Maybe -import Ideas.Text.Parsing -import System.IO.Error +import Ideas.Text.Parsing hiding (string, char) +import Prelude hiding (catch) +import System.IO.Error hiding (catch) import Test.QuickCheck +import Text.PrettyPrint.Leijen hiding ((<$>)) import qualified Ideas.Text.UTF8 as UTF8 import qualified Text.ParserCombinators.Parsec.Token as P @@ -43,20 +47,44 @@ data Number = I Integer | D Double deriving Eq +instance Show Number where + show (I n) = show n + show (D d) = show d + instance Show JSON where - show = showPretty + show = show . prettyJSON False -showCompact :: JSON -> String -showCompact json = - case json of - Number n -> show n - String s -> "\"" ++ escape s ++ "\"" - Boolean b -> if b then "true" else "false" - Array xs -> squareBrackets $ intercalate ", " $ map showCompact xs - Object xs -> let f (k, v) = show k ++ ": " ++ showCompact v - in curlyBrackets $ intercalate ", " $ map f xs - Null -> "null" +compactJSON :: JSON -> String +compactJSON = show . prettyJSON True +prettyJSON :: Bool -> JSON -> Doc +prettyJSON compact = rec + where + rec json = + case json of + Number n -> text (show n) + String s -> str (escape s) + Boolean b -> text (if b then "true" else "false") + Null -> text "null" + Array xs -> make lbracket rbracket (map rec xs) + Object xs -> make lbrace rbrace (map (uncurry (<:>)) xs) + + x <:> y | compact = str x <> char ':' <> rec y + | isSimple y = str x <> string ": " <> rec y + | otherwise = align (str x <> char ':' <> line <> indent 2 (rec y)) + + str = dquotes . text + + make open close xs + | compact || length xs < 2 = + enclose open close (hcat (intersperse comma xs)) + | otherwise = + align (vsep (zipWith (<+>) (open:repeat comma) xs ++ [close])) + + isSimple (Array xs) = null xs + isSimple (Object xs) = null xs + isSimple _ = True + -- Escape double quote and backslash, and convert to UTF8 encoding escape :: String -> String escape = concatMap f . fromMaybe "invalid UTF8 string" . UTF8.encodeM @@ -66,26 +94,6 @@ f '\\' = "\\\\" f c = [c] -showPretty :: JSON -> String -showPretty json = - case json of - Array xs -> squareBrackets $ '\n' : indent 3 (commas (map showPretty xs)) - Object xs -> let f (k, v) = show k ++ ": " ++ showPretty v - in curlyBrackets $ '\n' : indent 3 (commas (map f xs)) - _ -> showCompact json - where - commas [] = [] - commas [x] = x - commas (x:xs) = x ++ ",\n" ++ commas xs - -squareBrackets, curlyBrackets :: String -> String -squareBrackets s = "[" ++ s ++ "]" -curlyBrackets s = "{" ++ s ++ "}" - -instance Show Number where - show (I n) = show n - show (D d) = show d - class InJSON a where toJSON :: a -> JSON listToJSON :: [a] -> JSON @@ -236,24 +244,22 @@ lookupM x (Object xs) = maybe (fail $ "field " ++ x ++ " not found") return (lookup x xs) lookupM _ _ = fail "expecting a JSON object" -indent :: Int -> String -> String -indent n = unlines . map (replicate n ' ' ++) . lines - -------------------------------------------------------- -- JSON-RPC over HTTP -type RPCHandler m = String -> JSON -> m JSON +type RPCHandler = String -> JSON -> IO JSON -jsonRPC :: (MonadError a m, InJSON a) - => JSON -> RPCHandler m -> m RPCResponse -jsonRPC input handler = +jsonRPC :: JSON -> RPCHandler -> IO RPCResponse +jsonRPC input rpc = case fromJSON input of Nothing -> return (errorResponse (String "Invalid request") Null) Just req -> do - json <- handler (requestMethod req) (requestParams req) + json <- rpc (requestMethod req) (requestParams req) return (okResponse json (requestId req)) - `catchError` \msg -> - return (errorResponse (toJSON msg) (requestId req)) + `catch` handler req + where + handler :: RPCRequest -> IOException -> IO RPCResponse + handler req e = return (errorResponse (toJSON e) (requestId req)) -------------------------------------------------------- -- Testing parser/pretty-printer
src/Ideas/Text/OpenMath/FMP.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Formal mathematical properties (FMP) -- ----------------------------------------------------------------------------- +-- $Id: FMP.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.OpenMath.FMP where import Data.List (union)
src/Ideas/Text/OpenMath/Object.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -10,6 +10,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Object.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.OpenMath.Object ( OMOBJ(..), getOMVs, xml2omobj, omobj2xml ) where
src/Ideas/Text/OpenMath/Symbol.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Symbol.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.OpenMath.Symbol where type Symbol = (Maybe String, String)
src/Ideas/Text/OpenMath/Tests.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,6 +9,8 @@ -- Portability : portable (depends on ghc) -- ----------------------------------------------------------------------------- +-- $Id: Tests.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.OpenMath.Tests (propEncoding) where import Control.Monad
src/Ideas/Text/Parsing.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,6 +11,8 @@ -- Utility functions for parsing with Parsec library -- ----------------------------------------------------------------------------- +-- $Id: Parsing.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.Parsing ( module Export , (<*>), (*>), (<*), (<$>), (<$), (<**>)
src/Ideas/Text/UTF8.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,12 +11,14 @@ -- Support for the UTF8 encoding -- ----------------------------------------------------------------------------- +-- $Id: UTF8.hs 6541 2014-05-14 18:44:36Z bastiaan $ + module Ideas.Text.UTF8 ( encode, encodeM, decode, decodeM , isUTF8, allBytes, propEncoding ) where -import Control.Monad.Error +import Control.Monad import Data.Char import Data.Maybe import Test.QuickCheck
src/Ideas/Text/XML.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -12,19 +12,23 @@ -- functions defined elsewhere. -- ----------------------------------------------------------------------------- +-- $Id: XML.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.XML ( XML, Attr, AttrList, Element(..), InXML(..) , XMLBuilder, makeXML - , parseXML, showXML, compactXML, findAttribute + , parseXML, parseXMLFile, compactXML, findAttribute , children, Attribute(..), fromBuilder, findChild, getData , BuildXML(..) , module Data.Monoid, munless, mwhen ) where +import Control.Monad import Data.Char import Data.Foldable (toList) import Data.Monoid import Ideas.Text.XML.Interface hiding (parseXML) +import System.IO import qualified Data.Sequence as Seq import qualified Ideas.Text.XML.Interface as I @@ -51,6 +55,11 @@ ---------------------------------------------------------------- -- XML parser (a scanner and a XML tree constructor) +parseXMLFile :: FilePath -> IO XML +parseXMLFile file = + withBinaryFile file ReadMode $ + hGetContents >=> either fail return . parseXML + parseXML :: String -> Either String XML parseXML input = do xml <- I.parseXML input @@ -60,23 +69,6 @@ ignoreLayout (Element n as xs) = let f = either (Left . trim) (Right . ignoreLayout) in Element n as (map f xs) - -indentXML :: XML -> XML -indentXML = rec 0 - where - rec i (Element n as xs) = - let ipl = i+2 - cd j = Left ('\n' : replicate j ' ') - f = either (\x -> [cd ipl, Left x]) (\x -> [cd ipl, Right (rec ipl x)]) - body | null xs = xs - | otherwise = concatMap f xs ++ [cd i] - in Element n as body - -showXML :: XML -> String -showXML = (++"\n") . show . indentXML . ignoreLayout - -compactXML :: XML -> String -compactXML = show . ignoreLayout ---------------------------------------------------------------- -- XML builders
src/Ideas/Text/XML/Document.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,14 +11,19 @@ -- Datatype for representing XML documents -- ----------------------------------------------------------------------------- +-- $Id: Document.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.XML.Document ( Name, Attributes, Attribute(..), Reference(..), Parameter(..) , XMLDoc(..), XML(..), Element(..), Content, DTD(..), DocTypeDecl(..) , ContentSpec(..), CP(..), AttType(..), DefaultDecl(..), AttDef , EntityDef, AttValue, EntityValue, ExternalID(..), PublicID , Conditional(..), TextDecl, External + , prettyXML, prettyElement ) where +import Text.PrettyPrint.Leijen + type Name = String type Attributes = [Attribute] @@ -84,36 +89,58 @@ type External = (Maybe TextDecl, Content) ---- -{- -instance Show XMLDoc where - show doc = showXMLDecl doc ++ maybe "" show (dtd doc) ++ show (root doc) --} -instance Show Attribute where - show (n := v) = n ++ "=" ++ showAttValue v +------------------------------------------------------------------ +-- Showing -instance Show Element where - show (Element n as c) - | null c = showOpenTag True n as - | otherwise = showOpenTag False n as ++ concatMap show c ++ showCloseTag n +instance Show Attribute where show = show . pretty +instance Show Reference where show = show . pretty +instance Show Parameter where show = show . pretty +instance Show XML where show = show . pretty +instance Show Element where show = show . pretty -instance Show XML where - show xml = - case xml of - Tagged e -> show e - CharData s -> s - CDATA s -> "<![CDATA[" ++ s ++ "]]>" - Reference r -> show r +------------------------------------------------------------------ +-- Pretty printing -instance Show Reference where - show ref = +instance Pretty Attribute where + pretty (n := v) = text n <> char '=' <> prettyAttValue v + +instance Pretty Reference where + pretty ref = case ref of - CharRef n -> "&#" ++ show n ++ ";" - EntityRef s -> "&" ++ s ++ ";" + CharRef n -> text "&#" <> int n <> char ';' + EntityRef s -> char '&' <> text s <> char ';' -instance Show Parameter where - show (Parameter s) = "%" ++ s ++ ";" +instance Pretty Parameter where + pretty (Parameter s) = text "%" <> text s <> text ";" + +instance Pretty XML where + pretty = prettyXML False + +instance Pretty Element where + pretty = prettyElement False + +prettyXML :: Bool -> XML -> Doc +prettyXML compact xml = + case xml of + Tagged e -> prettyElement compact e + CharData s -> text s + CDATA s -> text "<![CDATA[" <> text s <> text "]]>" + Reference r -> pretty r + +prettyElement :: Bool -> Element -> Doc +prettyElement compact (Element n as c) + | null c = openCloseTag n as + | compact = make (<>) + | otherwise = make (<$>) + where + make op = let body = foldr1 op (map (prettyXML compact) c) + ibody = (if compact then id else indent 2) body + in openTag n as `op` ibody `op` closeTag n + {- +instance Show XMLDoc where + show doc = showXMLDecl doc ++ maybe "" show (dtd doc) ++ show (root doc) + instance Show DTD where show (DTD n mid ds) = "<!DOCTYPE " ++ unwords list ++ ">" where @@ -199,18 +226,23 @@ s2 = fmap (\s -> "encoding=" ++ doubleQuote s) (encoding doc) s3 = fmap (\b -> "standalone=" ++ doubleQuote (if b then "yes" else "no")) (standalone doc) -} -showOpenTag :: Bool -> Name -> Attributes -> String -showOpenTag close n as = "<" ++ unwords (n:map show as) ++ - (if close then "/>" else ">") +openTag :: Name -> Attributes -> Doc +openTag = prettyTag (char '<') (char '>') -showCloseTag :: Name -> String -showCloseTag n = "</" ++ n ++ ">" +openCloseTag :: Name -> Attributes -> Doc +openCloseTag = prettyTag (char '<') (text "/>") -showAttValue :: AttValue -> String -- TODO: no double quotes allowed (should be escaped) -showAttValue = doubleQuote . concatMap (either f show) +closeTag :: Name -> Doc +closeTag n = prettyTag (text "</") (char '>') n [] + +prettyTag :: Doc -> Doc -> Name -> Attributes -> Doc +prettyTag open close n as = open <> hsep (text n:map pretty as) <> close + +prettyAttValue :: AttValue -> Doc -- TODO: no double quotes allowed (should be escaped) +prettyAttValue = dquotes . hcat . map (either f pretty) where - f '"' = [] - f c = [c] + f '"' = empty + f c = char c {- showEntityValue :: EntityValue -> String showEntityValue = doubleQuote . concatMap (either f (either show show)) @@ -226,9 +258,6 @@ case entityDef of Left ev -> showEntityValue ev Right (eid, ms) -> show eid ++ maybe "" (" NDATA "++) ms --} -doubleQuote :: String -> String -doubleQuote s = "\"" ++ s ++ "\"" -{- + parenthesize :: String -> String parenthesize s = "(" ++ s ++ ")" -}
src/Ideas/Text/XML/Interface.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,9 +11,11 @@ -- Collection of common operation on XML documents -- ----------------------------------------------------------------------------- +-- $Id: Interface.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.XML.Interface ( Element(..), Content, Attribute(..), Attributes - , normalize, parseXML + , normalize, parseXML, compactXML , children, findAttribute, findChild, getData ) where @@ -21,7 +23,7 @@ import Data.Char (chr, ord) import Data.Maybe import Ideas.Text.Parsing (parseSimple) -import Ideas.Text.XML.Document (Name) +import Ideas.Text.XML.Document (Name, prettyElement) import Ideas.Text.XML.Parser (document) import Ideas.Text.XML.Unicode (decoding) import qualified Ideas.Text.XML.Document as D @@ -34,6 +36,9 @@ instance Show Element where show = show . extend + +compactXML :: Element -> String +compactXML = show . prettyElement True . extend type Content = [Either String Element]
src/Ideas/Text/XML/Parser.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -9,10 +9,12 @@ -- Portability : portable (depends on ghc) -- -- A parser for XML documents, directly derived from the specification: - +-- -- http://www.w3.org/TR/2006/REC-xml-20060816 - +-- ----------------------------------------------------------------------------- +-- $Id: Parser.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.XML.Parser (document, extParsedEnt, extSubset) where import Control.Monad @@ -26,10 +28,10 @@ import qualified Ideas.Text.XML.Document as D letter, digit, combiningChar, extender :: Parser Char -letter = ranges letterMap -digit = ranges digitMap -combiningChar = ranges combiningCharMap -extender = ranges extenderMap +letter = satisfy isLetter +digit = satisfy isDigit +combiningChar = satisfy isCombiningChar +extender = satisfy isExtender -- combinators without lexing (no spaces are consumed) parens, brackets, singleQuoted, doubleQuoted :: Parser a -> Parser a
src/Ideas/Text/XML/Unicode.hs view
@@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2013, Open Universiteit Nederland. This file is distributed +-- Copyright 2014, Open Universiteit Nederland. This file is distributed -- under the terms of the GNU General Public License. For more information, -- see the file "LICENSE.txt", which is included in the distribution. ----------------------------------------------------------------------------- @@ -11,53 +11,50 @@ -- Support for Unicode -- ----------------------------------------------------------------------------- +-- $Id: Unicode.hs 6535 2014-05-14 11:05:06Z bastiaan $ + module Ideas.Text.XML.Unicode ( isExtender, isLetter, isDigit, isCombiningChar - , extenderMap, letterMap, digitMap, combiningCharMap , decoding ) where +import Control.Arrow import Data.Char (chr, ord) import Data.List import qualified Ideas.Text.UTF8 as UTF8 -data Tree a = Node (Tree a) a (Tree a) | Leaf - +-- optimize for ascii characters isLetter, isExtender, isDigit, isCombiningChar :: Char -> Bool -isLetter = checkTree $ makeTree letterMap -isExtender = checkTree $ makeTree extenderMap -isDigit = checkTree $ makeTree digitMap -isCombiningChar = checkTree $ makeTree combiningCharMap - -checkTree :: Tree (Char, Char) -> Char -> Bool -checkTree Leaf _ = False -checkTree (Node l (c1, c2) r) c = - case compare c1 c of - LT -> case compare c c2 of - LT -> True - EQ -> True - GT -> checkTree r c - EQ -> True - GT -> checkTree l c +isLetter c = inMap (ord c) letterMap +isExtender c = inMap (ord c) extenderMap +isDigit c = inMap (ord c) digitMap +isCombiningChar c = inMap (ord c) combiningCharMap -makeTree :: [a] -> Tree a -makeTree [] = Leaf -makeTree xs = Node (makeTree ys) z (makeTree zs) - where (ys, z:zs) = splitAt n xs - n = length xs `div` 2 +inMap :: Int -> [(Int, Int)] -> Bool +inMap n = rec + where + rec [] = False + rec ((x, y):zs) + | n < x = False + | n <= y = True + | otherwise = rec zs f :: Char -> (Char, Char) f c = (c, c) -letterMap :: [(Char, Char)] -letterMap = baseCharMap `merge` ideographicMap `merge` controlMap `merge` extraMap +intpairs :: [(Char, Char)] -> [(Int, Int)] +intpairs = map (ord *** ord) -merge :: [(Char, Char)] -> [(Char, Char)] -> [(Char, Char)] +letterMap :: [(Int, Int)] +letterMap = baseCharMap `merge` ideographicMap -- `merge` controlMap `merge` extraMap + +merge :: [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)] merge (x:xs) (y:ys) - | x <= y = x:merge xs (y:ys) - | otherwise = y:merge (x:xs) ys + | fst x <= fst y = x:merge xs (y:ys) + | otherwise = y:merge (x:xs) ys merge xs ys = xs++ys +{- extraMap :: [(Char, Char)] extraMap = map f "\161\170\184\185" @@ -68,10 +65,11 @@ ('\x7FFFE', '\x7FFFF'), ('\x8FFFE', '\x8FFFF'), ('\x9FFFE', '\x9FFFF'), ('\xAFFFE', '\xAFFFF'), ('\xBFFFE', '\xBFFFF'), ('\xCFFFE', '\xCFFFF'), ('\xDFFFE', '\xDFFFF'), ('\xEFFFE', '\xEFFFF'), ('\xFFFFE', '\xFFFFF'), - ('\x10FFFE', '\x10FFFF')] + ('\x10FFFE', '\x10FFFF')] -} -baseCharMap :: [(Char, Char)] -baseCharMap = [ ('\x0041','\x005A'), ('\x0061','\x007A'), ('\x00C0','\x00D6'), +baseCharMap :: [(Int, Int)] +baseCharMap = intpairs + [ ('\x0041','\x005A'), ('\x0061','\x007A'), ('\x00C0','\x00D6'), ('\x00D8','\x00F6'), ('\x00F8','\x00FF'), ('\x0100','\x0131'), ('\x0134','\x013E'), ('\x0141','\x0148'), ('\x014A','\x017E'), ('\x0180','\x01C3'), ('\x01CD','\x01F0'), ('\x01F4','\x01F5'), @@ -127,13 +125,14 @@ f '\x212E' , ('\x2180','\x2182'), ('\x3041','\x3094'), ('\x30A1','\x30FA'), ('\x3105','\x312C'), ('\xAC00','\xD7A3') ] -ideographicMap :: [(Char, Char)] -ideographicMap = [ ('\x4E00','\x9FA5'), +ideographicMap :: [(Int, Int)] +ideographicMap = intpairs + [ ('\x4E00','\x9FA5'), f '\x3007' , ('\x3021','\x3029') ] -combiningCharMap :: [(Char, Char)] -combiningCharMap = [('\x0300','\x0345'), - ('\x0360','\x0361'), ('\x0483','\x0486'), ('\x0591','\x05A1'), +combiningCharMap :: [(Int, Int)] +combiningCharMap = intpairs + [('\x0300','\x0345'), ('\x0360','\x0361'), ('\x0483','\x0486'), ('\x0591','\x05A1'), ('\x05A3','\x05B9'), ('\x05BB','\x05BD'), f '\x05BF' , ('\x05C1','\x05C2'), f '\x05C4' , ('\x064B','\x0652'), f '\x0670' , ('\x06D6','\x06DC'), ('\x06DD','\x06DF'), ('\x06E0','\x06E4'), ('\x06E7','\x06E8'), @@ -159,16 +158,16 @@ ('\x0FB1','\x0FB7'), f '\x0FB9' , ('\x20D0','\x20DC'), f '\x20E1' , ('\x302A','\x302F'), f '\x3099' , f '\x309A' ] -digitMap :: [(Char, Char)] -digitMap = [ ('\x0030','\x0039'), +digitMap :: [(Int, Int)] +digitMap = intpairs [ ('\x0030','\x0039'), ('\x0660','\x0669'), ('\x06F0','\x06F9'), ('\x0966','\x096F'), ('\x09E6','\x09EF'), ('\x0A66','\x0A6F'), ('\x0AE6','\x0AEF'), ('\x0B66','\x0B6F'), ('\x0BE7','\x0BEF'), ('\x0C66','\x0C6F'), ('\x0CE6','\x0CEF'), ('\x0D66','\x0D6F'), ('\x0E50','\x0E59'), ('\x0ED0','\x0ED9'), ('\x0F20','\x0F29')] -extenderMap :: [(Char, Char)] -extenderMap = [f '\x00B7' , f '\x02D0' , +extenderMap :: [(Int, Int)] +extenderMap = intpairs [f '\x00B7' , f '\x02D0' , f '\x02D1' , f '\x0387' , f '\x0640' , f '\x0E46' , f '\x0EC6' , f '\x3005' , ('\x3031','\x3035') , ('\x309D','\x309E'), ('\x30FC','\x30FE') ]