1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
|
-- Fortgeschrittene Funktionale Programmierung,
-- LMU, TCS, Wintersemester 2015/16
-- Steffen Jost, Alexander Isenko
--
-- Übungsblatt 12. 20.01.2016
--
-- Thema: Database.Persist & Yesod.Persist
--
-- Anweisung:
-- Bearbeiten Sie ggf. zuerst noch A11-3 und A11-4,
-- falls Sie diese noch nicht bearbeitet haben!
--
-- Gehen Sie diese Datei durch und bearbeiten Sie
-- alle Vorkommen von undefined bzw. die mit -- !!! TODO !!!
-- markierten Stellen. Testen Sie Ihre Lösungen mit GHCi!
--
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
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
-- A11-1
--
-- Erstellen Sie mit Database.Persist ein simples Kommandozeilen-Tool
-- zum Zugriff auf eine Datenbank zur Verwaltung von Hausaufgaben.
-- Es soll immer auf die Datenbank im gleichen Verzeichnis zugegriffen werden.
--
-- Es gibt 3 Mögliche Verwendungsarten des Tools:
--
-- 1) > tool <name> <matrikel> <nr> <abgabe>
--
-- Legt eine Abgabe <abgabe> für Übung <nr>
-- von Student <name> mit Matrikelnummer <matrikel>
-- in der Datenbank ab.
-- Ist der Student unbekannt, so wird er angelegt.
-- Die Kombination aus Name und Matrikelnummer muss einzigartig sein.
--
-- 2) > tool <nr>
--
-- Zeigt alle Abgaben zur Übung <nr> auf dem Bildschrim an.
-- Zu jeder Abgabe wird auch der abgebende Student aufgeführt.
--
-- 3) > tool <name>
--
-- Zeigt alle Studenten mit diesem Namen an,
-- so wie jeweils die Anzahl der im System gespeicherten Abgaben
-- zu allen Übungen.
--
-- 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 = 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
-- Just use Text.Read.readMaybe
-- maybeRead :: Read a => String -> Maybe a
-- maybeRead (reads -> [(x,"")]) = Just x
-- maybeRead _ = Nothing
-- maybeToInt :: String -> Maybe Int
-- maybeToInt = maybeRead
{- DEMO:
> ./FFP_U11_Persist Steffen 1234 1 "Etwas gemacht"
Hallo zu HuniworX!
Migrating: CREATE TABLE "student"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,"matrikel" INTEGER NOT NULL,CONSTRAINT "unique_student" UNIQUE ("name","matrikel"))
Migrating: CREATE TABLE "abgabe"("id" INTEGER PRIMARY KEY,"ersteller_id" INTEGER NOT NULL REFERENCES "student","ubung" INTEGER NOT NULL,"abgabe" VARCHAR NOT NULL)
Abgabe von Steffen für Übung 1 angenommen.
> ./FFP_U11_Persist Steffen 6666 1 "Nix gemacht"
Hallo zu HuniworX!
Abgabe von Steffen für Übung 1 angenommen.
> ./FFP_U11_Persist Steffen 6666 2 "Fast nix gemacht"
Hallo zu HuniworX!
Abgabe von Steffen für Übung 2 angenommen.
> ./FFP_U11_Persist Steffen 1234 2 "Schön gemacht."
Hallo zu HuniworX!
Abgabe von Steffen für Übung 2 angenommen.
> ./FFP_U11_Persist Hilde 9999 2 "Vorbildlich gemacht."
Hallo zu HuniworX!
Abgabe von Hilde für Übung 2 angenommen.
> ./FFP_U11_Persist Steffen 1234 3 "Gut gemacht."
Hallo zu HuniworX!
Abgabe von Steffen für Übung 3 angenommen.
> ./FFP_U11_Persist Steffen
Hallo zu HuniworX!
Steffen 1234 Abgaben: 3
Steffen 6666 Abgaben: 2
> ./FFP_U11_Persist 2
Hallo zu HuniworX!
----
Steffen 6666 für Übung 2
Fast nix gemacht
----
Steffen 1234 für Übung 2
Schön gemacht.
----
Hilde 9999 für Übung 2
Vorbildlich gemacht.
> ./FFP_U11_Persist 1
Hallo zu HuniworX!
----
Steffen 1234 für Übung 1
Etwas gemacht
----
Steffen 6666 für Übung 1
Nix gemacht
> ./FFP_U11_Persist Fuu 1
Hallo zu HuniworX!
Optionen sind:
1) Studentenname
2) Übungsnummer
3) Studentenname, Matrikel, Übungsnr, Abgabe
Optionen 1 & 2 sind Abfragen; 3 ist Eingabe
>
-}
-- A11-2 TemplateHaskell
--
-- Hier ist etwas zum Knobeln oder Ausprobieren!
-- Was machen die folgenden TemplateHaskell Funktionen?
-- (zum Ausführen in ghci die Option -XTemplateHaskell nicht vergessen)
--
-- a) Extract ith member of n-tuple
foobar :: Int -> Int -> ExpQ
foobar n i = lamE [pat] rhs
where pat = tupP (map varP xs)
rhs = varE (xs !! (i - 1))
xs = [ mkName $ "x" ++ show j | j <- [1..n] ]
-- 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) @$(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"
let v i j = mkName $ "x" ++ (show i) ++ (show j)
let tupleps = [tupP [varP (v i j) | j <- [1..n]] | i <- [1..m] ]
let args = [(foldl appE (varE f) [varE $ v i j | i <- [1..m]]) | j <- [1..n]]
lamE ((varP f):tupleps) (tupE args)
|
