first commit

Ask.hs

@@ -0,0 +1,53 @@
+module Ask (decodeQuestions, encodeQuestions, correct, Question, readquestion)  where
+
+import Control.Monad
+import Control.Applicative
+import Data.List
+import Data.List.Split
+import Text.JSON
+
+data Question = Question {text :: String ,
+                                                     possibleAnswers :: [String],
+                                                     correctAnswer :: String}
+
+letters = join $ zipWith (\l n -> (replicate n) <$> l) (repeat ['a'..'z']) ([1, 2..])
+
+instance Show Question where
+    show (Question text answers correct) = (text ++ "\n" ++ possibleAnswers) where
+        possibleAnswers = (unlines (zipWith (\n a -> n ++"\t"++ a) letters answers))
+        
+instance Read Question where
+    readsPrec _ a = readquestion a
+
+readquestion q = decompose $ splitOn ":" q where
+    decompose (text:answers:correct:[]) = [(Question text (splitOn "|" answers) correct, "")]
+    decompose (_) = [(Question "" [] "", q)]
+
+instance JSON Question where
+    readJSON a = Ok (getInfo (Ok a))
+    showJSON (Question text posAns corAns) = JSObject (toJSObject [("question", putQuestion text), 
+                                                                                                                               ("answers", putAnswers posAns), 
+                                                                                                                               ("correct", putCorrect corAns)])
+
+getr (Ok a) = a
+getj (JSObject a) = a
+
+getQuestion attribute decoded = fromJSString $ getr $ (valFromObj attribute (getj $ getr decoded))
+getAnswers decoded = map fromJSString $ getr (valFromObj "answers" (getj $ getr decoded))
+
+getInfo decoded = Question (getQuestion "question" decoded) (getAnswers decoded) (getQuestion "correct" decoded)
+
+putAnswers possibleAnswers = JSArray $ map JSString $ map toJSString possibleAnswers
+putQuestion text = JSString $ toJSString text
+putCorrect answer = JSString $ toJSString answer
+
+correct :: String -> Question -> Bool
+correct answer question
+    | answer == (correctAnswer question) = True
+    | otherwise = False
+
+decodeQuestions :: String -> [Question]
+decodeQuestions json = getr $ decode json
+
+encodeQuestions :: [Question] -> String
+encodeQuestions q = encode q

questions.json

@@ -0,0 +1 @@
+[]

tell.hs

@@ -0,0 +1,37 @@
+import Ask
+import Control.Monad.Loops
+import Control.Monad
+import Data.List
+import System.Console.Readline
+import Text.Read.HT
+import qualified System.IO.Strict as So
+
+questionPath = "/home/wes/haskell/Questioner/questions.json"
+
+check = (readline "> ") >>= output where
+    output (Nothing) = return Nothing
+    output (Just a) | a == "END" = return Nothing
+                                | otherwise    = return (Just a)
+
+getQuestions = whileJust check return
+getQuestionFile = So.readFile questionPath
+
+-- Reads all of the questions and returns Nothing if they failed to parse
+maybeQuestions :: Monad m => m String -> m (Maybe Question)
+maybeQuestions questions =  (liftM (\x -> maybeRead x :: Maybe Question) questions)
+
+-- Unpacks all of the values
+dejust :: Monad m => m (m (Maybe r)) -> m r
+dejust values = liftM (\(Just x) -> x) $ join values
+
+-- get all of the questions from "questions.json" and then append the new ones to it
+refreshedQuestions :: IO [Question]
+refreshedQuestions = liftM2 (++) (liftM decodeQuestions getQuestionFile) (liftM newquestions getQuestions) where
+    -- Gets all of the new questions by filtering against ones that failed to parse
+    newquestions questions =  dejust $ filterM check (maybeQuestions questions) where
+        check (Just a) = return True
+        check (Nothing) = return False
+
+main = do
+    newqs <- (liftM encodeQuestions refreshedQuestions)
+    writeFile questionPath newqs