From 96da4a51acd4ab7c7c77b6709bc496153b78b678 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Tue, 19 Jan 2016 12:03:55 +0100
Subject: FFP 12

---
 ws2015/ffp/blaetter/12/FFP_U12_Persist.hs | 82 +++++++++++++++++++++++--------
 1 file changed, 62 insertions(+), 20 deletions(-)

(limited to 'ws2015')

diff --git a/ws2015/ffp/blaetter/12/FFP_U12_Persist.hs b/ws2015/ffp/blaetter/12/FFP_U12_Persist.hs
index c087fae..a9ff044 100644
--- a/ws2015/ffp/blaetter/12/FFP_U12_Persist.hs
+++ b/ws2015/ffp/blaetter/12/FFP_U12_Persist.hs
@@ -32,11 +32,15 @@ import Database.Persist
 import Database.Persist.Sqlite
 import Database.Persist.TH
 import System.Environment (getArgs)
+import Control.Monad.Logger (NoLoggingT)
+import Control.Monad.Trans.Resource (ResourceT)
 
 import Control.Applicative
 import Control.Monad
 import Control.Monad.IO.Class
 
+import Text.Read (readMaybe)
+
 -- Nur für A11-2 benötigt:
 import Language.Haskell.TH
 
@@ -70,31 +74,68 @@ import Language.Haskell.TH
 --
 -- Ein Demo folgt weiter unten.
 
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+Student
+  name String
+  matrikel Int
+  UniqueStudent name matrikel
+Abgabe
+  erstellerId StudentId
+  ubung Int
+  abgabe String
+|]
 
 sqliteDB = "demo.sqlite"
 
+type SQLite a = SqlPersistT (NoLoggingT (ResourceT IO)) a
+
 main :: IO ()
-main = do
-    putStrLn "Hallo zu HuniworX!"
-    args <- getArgs
-    -- !!! TODO !!!
-    return ()
+main = runSqlite sqliteDB $ do
+  liftIO $ putStrLn "Hallo zu HuniworX!"
+
+  runMigration migrateAll
+
+  liftIO getArgs >>= action
+
+action :: [String] -> SQLite ()
+action [(readMaybe -> Just ubungsNr)] = mapM_ listAbgabe =<< selectList [AbgabeUbung ==. ubungsNr] []
+
+action [name] = mapM_ listAbgabenCount =<< selectList [StudentName ==. name] []
+
+action [name, (readMaybe -> Just matrikel), (readMaybe -> Just ubungsNr), abgabe] = do
+  ersteller <- getBy $ UniqueStudent name matrikel
+  erstellerId <- case ersteller of
+    Just (Entity id _) -> return id
+    Nothing            -> insert $ Student name matrikel
+  insert $ Abgabe erstellerId ubungsNr abgabe
+  liftIO . putStrLn $ "Abgabe von " ++ name ++ " für Übung " ++ (show ubungsNr) ++ " angenommen"
+
+action _ = liftIO . putStr . unlines $ [ "Optionen sind:"
+                                       , " 1) Studentenname"
+                                       , " 2) Übungsnummer"
+                                       , " 3) Studentenname, Matrikel, Übungsnr, Abgabe"
+                                       , "Optionen 1 & 2 sind Abfragen; 3 ist Eingabe"
+                                       ]
+
+listAbgabe :: Entity Abgabe -> SQLite ()
+listAbgabe (Entity _ (Abgabe erstellerId ubung abgabe)) = do
+  (Just (Student name matrikel)) <- get $ erstellerId -- If the database is inconsistent we simply crash since I couldn't be bothered to fail more gracefully
+  liftIO . putStrLn $ "----\n" ++ name ++ " " ++ show matrikel ++ " für Übung " ++ show ubung
+  liftIO . mapM_ (putStrLn . ("\t" ++)) . lines $ abgabe
 
+listAbgabenCount :: Entity Student -> SQLite ()
+listAbgabenCount (Entity studentId (Student name matrikel)) = do
+  abgabenCount <- length <$> selectList [AbgabeErstellerId ==. studentId] []
+  liftIO . putStrLn $ name ++ " " ++ show matrikel ++ " Abgaben: " ++ show abgabenCount
 
-hilfstext :: IO ()
-hilfstext = do
-  putStrLn "Optionen sind:"
-  putStrLn " 1) Studentenname"
-  putStrLn " 2) Übungsnummer"
-  putStrLn " 3) Studentenname, Matrikel, Übungsnr, Abgabe"
-  putStrLn "Optionen 1 & 2 sind Abfragen; 3 ist Eingabe"
 
-maybeRead :: Read a => String -> Maybe a
-maybeRead (reads -> [(x,"")]) = Just x
-maybeRead _ = Nothing
+-- Just use Text.Read.readMaybe
+-- maybeRead :: Read a => String -> Maybe a
+-- maybeRead (reads -> [(x,"")]) = Just x
+-- maybeRead _ = Nothing
 
-maybeToInt :: String -> Maybe Int
-maybeToInt = maybeRead
+-- maybeToInt :: String -> Maybe Int
+-- maybeToInt = maybeRead
 
 
 {- DEMO:
@@ -162,7 +203,7 @@ Optionen 1 & 2 sind Abfragen; 3 ist Eingabe
 -- (zum Ausführen in ghci die Option -XTemplateHaskell nicht vergessen)
 --
 
--- a)
+-- a) Extract ith member of n-tuple
 foobar :: Int -> Int -> ExpQ
 foobar n i = lamE [pat] rhs
   where pat = tupP (map varP xs)
@@ -170,14 +211,15 @@ foobar n i = lamE [pat] rhs
         xs  = [ mkName $ "x" ++ show j | j <- [1..n] ]
 
 
--- b)
+-- b) Convert list of length ≥ n to n-tuple
 barfoo :: Int -> ExpQ
 barfoo n = do
     ns <- replicateM n (newName "x")
     lamE [foldr (\x y -> conP '(:) [varP x,y]) wildP ns] (tupE $ map varE ns)
 
 
--- c)
+-- c) @$(fuubaz n m) f@ is a m-ary function on n-tuples returning an n-tuple whose ith component is the result of applying the m-ary function f to the ith components of the codomain
+-- It's the curried variant of transposition on tuples followed by pointwise application of an uncurried variant of f
 fuubaz:: Int -> Int -> ExpQ
 fuubaz n m = do
   let f       = mkName "f"
-- 
cgit v1.2.3