/
Tuples.hs
103 lines (85 loc) · 3.77 KB
/
Tuples.hs
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
module Main where
import Data.List (intersperse)
import System.Environment (getArgs)
--------------------------------------------------------------------------------
-- Tuples
--------------------------------------------------------------------------------
u, tab, newline, sp :: ShowS
u = showChar '_'
tab = showString " "
newline = showChar '\n'
sp = showChar ' '
vars :: [ShowS]
vars = map ((showChar 'x' .) . shows) [1..]
paren :: ShowS -> ShowS
paren x = showChar '(' . x . showChar ')'
concatS :: [ShowS] -> ShowS
concatS = foldr (.) id
tuple :: Int -> ShowS
tuple m = showChar '(' . showString (replicate (m-1) ',') . showChar ')'
unlinesS :: [ShowS] -> ShowS
unlinesS = foldr1 (\a b -> a . newline . b)
createDataDecls :: Int -> ShowS
createDataDecls m = let n = shows m
s = showString "data Tuple"
in s . n . u . newline . s . n . showChar 'C' . u
dataInstance :: Int -> ShowS
dataInstance m = let n = shows m
l1 = showString "instance Datatype Tuple"
. n . u . showString " where"
l2 = tab . showString "datatypeName _ = \""
. tuple m . showChar '"'
l3 = tab . showString "moduleName _ = \"Prelude\""
in unlinesS [l1, l2, l3]
conInstance :: Int -> ShowS
conInstance m = let n = shows m
in showString "instance Constructor Tuple" . n . u
. showString " where conName _ = \"" . tuple m . showChar '"'
-- x is 0 or 1
pairPat, repName, rep, repInst, funs :: Int -> Int -> ShowS
pairPat x m = tuple m . sp .
(concatS $ intersperse sp (take (m - x) vars))
repName x m = showString "Rep" . shows x . showString "Tuple" . shows m . u
rep x m = let n = shows m
v = take (m - x) vars
vs = concatS $ intersperse sp v
recs = concatS $ intersperse (showString " :*: ") $
map (showString "Rec0 " .) v
last = showString $ if (x == 1) then " :*: Par1" else ""
body = recs . last
in showString "type " . repName x m . sp . vs
. showString " = D1 Tuple" . n . showString "_ (C1 Tuple" . n
. showString "C_ (S1 NoSelector (" . body . showString ")))"
repInst x m = let n = shows m
y = shows x
vs = concatS $ intersperse sp (take (m - x) vars)
in showString "instance Representable" . y . sp
. paren (pairPat x m) . showString " (" . repName x m . sp
. vs . showString ") where"
. newline . funs x m
funs x m =
let v = take (m - x) vars
recs = concatS $ intersperse (showString " :*: ") $
map (showString "K1 " .) v
last = if (x == 1) then showString " :*: Par1 " . (vars !! (m-x))
else showString ""
eq = showChar '='
body = paren (showString "M1 (M1 (M1 (" . recs . last . showString ")))")
pat = paren (pairPat 0 m)
in tab . concatS (intersperse sp [showString "from" . shows x, pat, eq, body])
. newline .
tab . concatS (intersperse sp [showString "to" . shows x, body, eq, pat])
gen :: Int -> ShowS
gen m = concatS (intersperse (newline . newline)
[ createDataDecls m, dataInstance m, conInstance m
, rep 0 m, repInst 0 m, rep 1 m, repInst 1 m])
main :: IO ()
main = do let r :: [String] -> Int
r (n:_) = read n
r _ = error "Integer argument missing"
com = showString "\n\n"
. concatS (map showChar (replicate 80 '-'))
. showString "\n\n"
a <- getArgs
(putStr . ($ "")) $ concatS $
intersperse com [ gen m | m <- [2..(r a)]]