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
|
{-# LANGUAGE DeriveDataTypeable #-}
module Data.Derive.DSL.DSL where
import Data.Derive.DSL.HSE
import Data.List
import Data.Data
import Data.Generics.Uniplate.DataOnly
data DSL = App String DSL{-List-}
| Concat DSL
| Reverse DSL
| String String
| ShowInt DSL
| Int Integer
| List [DSL]
| MapField DSL
| MapCtor DSL
| DataName
| CtorName
| CtorIndex
| CtorArity
| FieldIndex
| Fold DSL DSL
| Head
| Tail
| Instance [String] String DSL{-[InstDecl]-}
| Application DSL{-List-}
deriving (Data,Typeable,Show)
box x = List [x]
nil = List []
append x y = Concat $ List [x,y]
fromOut :: Output -> DSL
fromOut (OApp x y) = App x (List $ map fromOut y)
fromOut (OList x) = List (map fromOut x)
fromOut (OString x) = String x
fromOut x = error $ show ("fromOut",x)
{-
_1 s x1 = App s $ List [x1]
_2 s x1 x2 = App s $ List [x1,x2]
_3 s x1 x2 x3 = App s $ List [x1,x2,x3]
_5 s x1 x2 x3 x4 x5 = App s $ List [x1,x2,x3,x4,x5]
o x = fromOut $ out x
dslEq :: DSL
dslEq = box $ Instance ["Eq"] "Eq" $ box $ _1 "InsDecl" $ _1 "FunBind" $ match `append` dull
where
match = MapCtor $ _5 "Match" (o $ Symbol "==") (List [vars "x",vars "y"]) (o (Nothing :: Maybe Type)) (_1 "UnGuardedRhs" bod) (o $ BDecls [])
vars x = _2 "PApp" (_1 "UnQual" $ _1 "Ident" CtorName) (MapField (_1 "PVar" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)))
bod = Fold (_3 "InfixApp" Head (o $ QVarOp $ UnQual $ Symbol "&&") Tail) $ MapField pair `append` o [Con $ UnQual $ Ident "True"]
pair = _3 "InfixApp" (var "x") (o $ QVarOp $ UnQual $ Symbol "==") (var "y")
var x = _1 "Var" $ _1 "UnQual" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)
dull = o [Match sl (Symbol "==") [PWildCard,PWildCard] Nothing (UnGuardedRhs $ Con $ UnQual $ Ident "False") (BDecls [])]
-}
simplifyDSL :: DSL -> DSL
simplifyDSL = transform f
where
f (Concat (List xs)) = case g xs of
[x] -> x
[] -> List []
xs -> Concat $ List xs
f x = x
g (List x:List y:zs) = g $ List (x++y):zs
g (List []:xs) = g xs
g (String "":xs) = g xs
g (x:xs) = x : g xs
g [] = []
prettyTex :: DSL -> String
prettyTex = f id . transform g
where
bracket x = "(" ++ x ++ ")"
f b (App x (List [])) = x
f b (App x (List xs)) = b $ unwords $ x : map (f bracket) xs
f b (App x y) = b $ x ++ " " ++ f bracket y
f b (Concat x) = b $ "concat " ++ f bracket x
f b (Reverse x) = b $ "reverse " ++ f bracket x
f b (String x) = show x
f b (ShowInt x) = b $ "showInt " ++ f bracket x
f b (Int x) = show x
f b (List []) = "nil"
f b (List x) = b $ "list (" ++ concat (intersperse "," $ map (f id) x) ++ ")"
f b (MapField x) = b $ "mapField " ++ f bracket x
f b (MapCtor x) = b $ "mapCtor " ++ f bracket x
f b DataName = "dataName"
f b CtorName = "ctorName"
f b CtorIndex = "ctorIndex"
f b CtorArity = "ctorArity"
f b FieldIndex = "fieldIndex"
f b (Fold x y) = b $ "fold " ++ f bracket x ++ " " ++ f bracket y
f b Head = "head"
f b Tail = "tail"
f b (Instance x y z) = b $ "instance_ " ++ show x ++ " " ++ show y ++ " " ++ f bracket z
f b (Application x) = b $ "application " ++ f bracket x
g (App x (List [y])) | x `elem` words "Ident UnGuardedRhs UnQual Lit" = y
g x = x
|
