Merge pull request #50 from ideas-edu/ideas-bastiaan

Ideas bastiaan

CHANGELOG.txt

@@ -11,6 +11,7 @@ Changelog ideas-1.7 => ideas-1.8
 * extending derivation interface (in Ideas.Common.Derivation)
 * refactoring logging interface and database name
 * new general Decoding module in utils; refactored encoders/decoders
+* moving unicode decoding from parseXML/parseJSON to Main.Default
 
 Changelog ideas-1.6 => ideas.1.7
 

src/Ideas/Common/Derivation.hs

@@ -50,7 +50,7 @@ instance Functor (Derivation s) where
 instance BiFunctor Derivation where
    biMap f g (D a xs) = D (g a) (fmap (biMap f g) xs)
 
-instance (IsTerm s, IsTerm a) => IsTerm (Derivation s a) where 
+instance (IsTerm s, IsTerm a) => IsTerm (Derivation s a) where
    toTerm = TList . derivationToList toTerm toTerm
    fromTerm (TList xs) = derivationFromList fromTerm fromTerm xs
    fromTerm _ = fail "not a derivation"
@@ -75,15 +75,14 @@ mergeBy eq d@(D a xs) (D b ys)
    | eq (lastTerm d) b = Just $ D a (xs <> ys)
    | otherwise = Nothing
 
-
 mergeStep :: Derivation s a -> s -> Derivation s a -> Derivation s a
 mergeStep (D a xs) s (D b ys) = D a (xs <> ((s, b) S.<| ys))
 
 -----------------------------------------------------------------------------
 -- Conversion to/from list
 
 derivationToList :: (s -> b) -> (a -> b) -> Derivation s a -> [b]
-derivationToList f g d = 
+derivationToList f g d =
    g (firstTerm d) : concat [ [f s, g a] | (_, s, a) <- triples d ]
 
 derivationFromList :: Monad m => (b -> m s) -> (b -> m a) -> [b] -> m (Derivation s a)
@@ -143,7 +142,7 @@ derivationM :: Monad m => (s -> m ()) -> (a -> m ()) -> Derivation s a -> m ()
 derivationM f g (D a xs) = g a >> mapM_ (\(s, b) -> f s >> g b) (F.toList xs)
 
 splitStep :: (s -> Bool) -> Derivation s a -> Maybe (Derivation s a, s, Derivation s a)
-splitStep p (D a xs) = 
+splitStep p (D a xs) =
    case S.viewl xs2 of
       S.EmptyL -> Nothing
       (s, b) S.:< ys -> Just (D a xs1, s, D b ys)

src/Ideas/Common/Examples.hs

@@ -9,27 +9,27 @@
 -- Portability :  portable (depends on ghc)
 --
 -- * This module provides an interface to structure a collection of examples.
--- Examples can be taken from (lists of) concrete values, or from random 
+-- Examples can be taken from (lists of) concrete values, or from random
 -- generators. Both types can be marked as test items. Examples can be assigned
 -- a level of difficulty (ranging from very easy to very difficult). Test items
 -- do not have a difficulty level. Examples can be grouped into sub-collections
--- and assigned an identifier. Use the @Monoid@ operations for combining 
+-- and assigned an identifier. Use the @Monoid@ operations for combining
 -- examples.
--- 
+--
 -----------------------------------------------------------------------------
 
 module Ideas.Common.Examples
-   ( -- * Examples type 
+   ( -- * Examples type
      Examples
-     -- * Constructing examples  
+     -- * Constructing examples
    , example, exampleList, examplesFor, examplesWithDifficulty
    , random, group, forTesting
      -- * Assigning difficulty
    , difficulty, veryEasy, easy, medium, difficult, veryDifficult
-     -- * Transformations and queries 
+     -- * Transformations and queries
    , isEmpty, size, flatten, groups
    , topLevelExamples, topLevelRandoms, topLevelTests, topLevelRandomTests
-   , allExamples, allRandoms, allTests, allRandomTests  
+   , allExamples, allRandoms, allTests, allRandomTests
      -- * Difficulty type
    , Difficulty(..), readDifficulty
    ) where
@@ -112,28 +112,28 @@ forTesting = changeItems f
 
 -- | Top-level examples
 topLevelExamples :: Examples a -> [(Maybe Difficulty, a)]
-topLevelExamples = collectItems f  
+topLevelExamples = collectItems f
  where
    f (Example md a) = Just (md, a)
    f _ = Nothing
 
 -- | Top-level random generators
 topLevelRandoms :: Examples a -> [(Maybe Difficulty, Gen a)]
-topLevelRandoms = collectItems f 
+topLevelRandoms = collectItems f
  where
    f (Random md g) = Just (md, g)
    f _ = Nothing
 
 -- | Top-level test cases
 topLevelTests :: Examples a -> [a]
-topLevelTests = collectItems f 
+topLevelTests = collectItems f
  where
    f (Test a) = Just a
    f _ = Nothing
 
 -- | Top-level test generators
 topLevelRandomTests :: Examples a -> [Gen a]
-topLevelRandomTests = collectItems f 
+topLevelRandomTests = collectItems f
  where
    f (RandomTest g) = Just g
    f _ = Nothing
@@ -217,7 +217,7 @@ readDifficulty s =
  where
    normal = filter isAlpha . map toLower
    p = (== normal s) . normal . show
-   
+
 veryEasy, easy, medium, difficult, veryDifficult :: Examples a -> Examples a
 veryEasy      = difficulty VeryEasy
 easy          = difficulty Easy

src/Ideas/Common/Exercise.hs

@@ -288,7 +288,7 @@ randomTerms :: QCGen -> Exercise a -> Maybe Difficulty -> [a]
 randomTerms rng ex mdif = rec rng
  where
    rec a = maybe id (:) (randomTerm a ex mdif) (rec (snd (next a)))
-    
+
 -- | An exercise generator for testing purposes (including corner cases); first generator only.
 testGenerator :: Exercise a -> Maybe (Gen a)
 testGenerator = listToMaybe . allRandomTests . examples

src/Ideas/Common/ExerciseTests.hs

@@ -73,7 +73,7 @@ exerciseTestSuite qcgen ex = suite ("Exercise " ++ show (exerciseId ex)) $
  where
    rs = randomTerms qcgen ex Nothing
    xs | null rs   = examplesAsList ex
-      | otherwise = take 10 rs 
+      | otherwise = take 10 rs
 
 data ShowAs a = S {showS :: a -> String, fromS :: a}
 

src/Ideas/Common/Rewriting/AutoTerm.hs

@@ -18,7 +18,7 @@ import Ideas.Common.Rewriting.Term
 import Ideas.Utils.Prelude (headM)
 
 toTermG :: Data a => a -> Term
-toTermG a = 
+toTermG a =
    case constrRep constr of
       IntConstr n   -> TNum n                  -- for Int and Integer
       FloatConstr r -> TFloat (fromRational r) -- for Double and Float
@@ -30,22 +30,22 @@ toTermG a =
  where
    op (M xs) x = M (xs ++ [toTermG x])
    e _    = M []
-   constr = toConstr a 
+   constr = toConstr a
 
 newtype M a = M [Term]
 
 -- test for list constructors
 makeTerm :: Constr -> M a -> Term
 makeTerm c (M xs) =
-   case xs of 
+   case xs of
       [y, TList ys] | isCons  -> TList (y:ys)
       []            | isNil   -> TList []
       _ -> TCon (constrSymbol c) xs
  where
    txt = showConstr c
    isNil   = txt == "[]"
    isCons  = txt == "(:)"
-   
+
 isTuple :: String -> Bool
 isTuple ('(':xs) = rec xs
  where
@@ -56,7 +56,7 @@ isTuple _       = False
 
 ------------------------------------------------------------------------
 
-constrSymbol :: Constr -> Symbol 
+constrSymbol :: Constr -> Symbol
 constrSymbol c
    | txt == "[]"  = nilSymbol
    | txt == "(:)" = consSymbol
@@ -77,7 +77,7 @@ constructors = dataTypeConstrs . dataTypeOf . fromProxy
    fromProxy = error "fromProxy"
 
 findConstr :: (Monad m, Data a) => Proxy a -> Symbol -> m Constr
-findConstr p s = 
+findConstr p s =
    headM [ c | c <- constructors p, s == constrSymbol c ]
 
 fromTermG :: (MonadPlus m, Data a) => Term -> m a
@@ -95,7 +95,7 @@ fromTermG term =
    nil  = symbol nilSymbol
 
 castM :: (Monad m, Typeable a, Typeable b) => a -> m b
-castM = maybe (fail "fromTermG") return . cast 
+castM = maybe (fail "fromTermG") return . cast
 
 doubleToFloat :: Double -> Float
 doubleToFloat = fromRational . toRational

src/Ideas/Common/Strategy/Traversal.hs

@@ -31,14 +31,14 @@ module Ideas.Common.Strategy.Traversal
    ) where
 
 import Data.Monoid hiding ((<>))
-import qualified Data.Semigroup as Sem
 import Data.Semigroup ((<>))
 import Ideas.Common.Classes
 import Ideas.Common.Rule
 import Ideas.Common.Strategy.Abstract
 import Ideas.Common.Strategy.Combinators
 import Ideas.Common.Traversal.Navigator
 import Prelude hiding (repeat, not, traverse)
+import qualified Data.Semigroup as Sem
 import qualified Prelude
 
 ----------------------------------------------------------------------

src/Ideas/Encoding/Encoder.hs

@@ -38,7 +38,7 @@ import Ideas.Service.FeedbackScript.Parser (Script)
 import Ideas.Service.Types
 import Ideas.Text.JSON hiding (String)
 import Ideas.Text.Latex
-import Ideas.Utils.Decoding 
+import Ideas.Utils.Decoding
 import Test.QuickCheck.Random
 import qualified Ideas.Common.Rewriting.Term as Term
 import qualified Ideas.Text.JSON as JSON

src/Ideas/Encoding/EncoderHTML.hs

@@ -40,8 +40,8 @@ import Ideas.Text.HTML.W3CSS hiding (tag, ul, top, table, content)
 import Ideas.Text.OpenMath.FMP
 import Ideas.Text.OpenMath.Object
 import Ideas.Text.XML hiding (content)
-import Ideas.Utils.TestSuite
 import Ideas.Utils.Prelude (munless, mwhen)
+import Ideas.Utils.TestSuite
 import System.IO.Unsafe
 import qualified Ideas.Text.HTML.W3CSS as W3
 
@@ -151,12 +151,12 @@ encodeConst dr tv@(val ::: tp) =
       Term        -> text val
       Context     -> encodeContext val
       String      -> string val
-      Result      -> exerciseHeader (encodeResult val) 
+      Result      -> exerciseHeader (encodeResult val)
       _           -> text tv
 
 encodeContext :: Context a -> HTMLEncoder a
 encodeContext ctx = (\ex -> string (prettyPrinterContext ex ctx)) <$> getExercise
-  
+
 encodeIndex :: DomainReasoner -> HTMLEncoder a
 encodeIndex dr = return $ mconcat
    [ htmlDescription "Domain reasoner" dr
@@ -177,7 +177,7 @@ encodeIndex dr = return $ mconcat
            ])
    ]
 
-encodeServiceList :: [Service] -> HTMLEncoder a 
+encodeServiceList :: [Service] -> HTMLEncoder a
 encodeServiceList srvs = do
    lm <- getLinkManager
    return $
@@ -262,8 +262,8 @@ productType tp =
       _          -> [Some tp]
 
 encodeExercise :: Exercise a -> HTMLEncoder a
-encodeExercise ex = do 
-   lm <- getLinkManager 
+encodeExercise ex = do
+   lm <- getLinkManager
    return $ mconcat
       [ generalInfo lm
       , h2 "Example exercises"
@@ -392,7 +392,7 @@ showRating lm = rec (5::Int)
           | a == 1    = "star_2.png"
           | otherwise = "star_3.png"
 
-encodeRuleList :: [Rule (Context a)] -> HTMLEncoder a 
+encodeRuleList :: [Rule (Context a)] -> HTMLEncoder a
 encodeRuleList rs = withExercise $ \ex -> do
    lm <- getLinkManager
    let (rs1, rs2) = partition isBuggy rs
@@ -444,7 +444,7 @@ encodeRule r = withExercise $ \ex ->
       ]
 
 encodeExampleList :: [(Difficulty, Context a)] -> HTMLEncoder a
-encodeExampleList pairs = withExercise $ \ex -> do 
+encodeExampleList pairs = withExercise $ \ex -> do
    lm <- getLinkManager
    return $ mconcat $
       h2 "Examples" :
@@ -490,7 +490,7 @@ htmlDerivation d = withExercise $ \ex -> do
    return $ htmlDerivationWith before forStep forTerm (diffEnvironment d)
 
 htmlState :: State a -> HTMLEncoder a
-htmlState state = do 
+htmlState state = do
    lm <- getLinkManager
    return $ para $ container $ background LightGray $ para $
       stateLink lm state
@@ -586,8 +586,8 @@ htmlDerivationWith before forStep forTerm d =
       before : forTerm (firstTerm d) :
          [ forStep s <> forTerm a | (_, s, a) <- triples d ]
 
-htmlFirsts :: [(StepInfo a, State a)] -> HTMLEncoder a 
-htmlFirsts xs = 
+htmlFirsts :: [(StepInfo a, State a)] -> HTMLEncoder a
+htmlFirsts xs =
    h2 "Firsts" <>
    ul [ keyValueTable
            [ ("Rule", string $ showId r)

src/Ideas/Encoding/EncoderJSON.hs

@@ -19,8 +19,8 @@ import Control.Applicative hiding (Const)
 import Data.Maybe
 import Ideas.Common.Library hiding (exerciseId)
 import Ideas.Encoding.Encoder
-import Ideas.Service.State
 import Ideas.Encoding.Request
+import Ideas.Service.State
 import Ideas.Service.Types hiding (String)
 import Ideas.Text.JSON
 import Ideas.Utils.Prelude (distinct)
@@ -101,7 +101,7 @@ encodeContext ctx = f . useJSONTerm <$> getRequest <*> getExercise
    f False ex = String $ prettyPrinterContext ex ctx
 
 encodeState :: State a -> JSONEncoder a
-encodeState st = 
+encodeState st =
    let ctx   = stateContext st
        get f = String (fromMaybe "" (f st))
        make pp env = Array $

src/Ideas/Encoding/EncoderXML.hs

@@ -25,11 +25,11 @@ import Data.Monoid
 import Ideas.Common.Library hiding (exerciseId)
 import Ideas.Encoding.Encoder
 import Ideas.Encoding.OpenMathSupport
+import Ideas.Encoding.Request hiding (XML)
 import Ideas.Encoding.RulesInfo (rulesInfoXML)
 import Ideas.Encoding.StrategyInfo
 import Ideas.Service.Diagnose
 import Ideas.Service.FeedbackScript.Syntax
-import Ideas.Encoding.Request hiding (XML)
 import Ideas.Service.State
 import Ideas.Service.Types
 import Ideas.Text.OpenMath.Object
@@ -135,7 +135,7 @@ buildExpression useOM ex
  where
    msg s = error ("Error encoding term in OpenMath: " ++ s)
 
-encodeLocation :: Location -> XMLEncoder a 
+encodeLocation :: Location -> XMLEncoder a
 encodeLocation loc = "location" .=. show loc
 
 encodeEnvironment :: HasEnvironment env => env -> XMLEncoder a
@@ -189,7 +189,7 @@ encodeText txt = do
          _ -> text item
 
 encodeMessage :: FeedbackText.Message -> XMLEncoder a
-encodeMessage msg = 
+encodeMessage msg =
    element "message"
       [ case FeedbackText.accept msg of
            Just b  -> "accept" .=. showBool b

src/Ideas/Encoding/Logging.hs

@@ -239,4 +239,4 @@ selectFrom database table columns f = do
    xs   <- mapM (f . map fromSql) rows
    disconnect con
    return xs
-#endif
+#endif

src/Ideas/Main/Default.hs

@@ -35,6 +35,7 @@ import Ideas.Service.DomainReasoner
 import Ideas.Service.FeedbackScript.Analysis
 import Ideas.Service.ServiceList
 import Ideas.Service.Types (Service)
+import Ideas.Text.XML.Unicode (decoding)
 import Ideas.Utils.BlackBoxTests
 import Ideas.Utils.Prelude
 import Ideas.Utils.TestSuite
@@ -65,7 +66,7 @@ defaultCGI options dr = CGI.run $ \req respond -> do
    -- query environment
    let script = fromMaybe "" (findHeader "CGI-Script-Name" req) -- get name of binary
        addr   = fromMaybe "" (findHeader "REMOTE_ADDR" req)     -- the IP address of the remote host
-   input   <- inputOrDefault req
+   input   <- inputOrDefault req >>= decoding
    -- process request
    (preq, txt, ctp) <-
       process (optionCgiBin script options) dr input
@@ -121,7 +122,7 @@ defaultCommandLine options dr cmdLineOptions = do
             processDatabase dr database
          InputFile file ->
             withBinaryFile file ReadMode $ \h -> do
-               input  <- hGetContents h
+               input  <- hGetContents h >>= decoding
                (req, txt, _) <- process options dr input
                putStrLn txt
                when (PrintLog `elem` cmdLineOptions) $ do
@@ -166,7 +167,7 @@ process options dr input = do
 
 makeTestRunner :: DomainReasoner -> String -> IO String
 makeTestRunner dr input = do
-   (_, out, _) <- process mempty dr input
+   (_, out, _) <- decoding input >>= process mempty dr
    return out
 
 addVersion :: DomainReasoner -> DomainReasoner