Prelude/Template.ad

Outline
module Prelude.Template
GetTypeVar (template)
GetTypeVars (template)
GetTypeVarsNumbered (template)
Intercalate (template)
Commafy (template)
BuildTuple (template)
BuildTupleLeft (template)
BuildTupleRight (template)
IsSimpleEnumDatatype (template)
AddArgs (template)
ConstWithWildcardArgs (template)
ConstWithArgs (template)
TypeWithArgs (template)
GenerateRecognisers (template)
ClassWithArgs (template)
BuildInstanceHeader (template)
BuildInstance (template)
DeriveInstanceComputeSuperDefault (template)
DeriveInstance (template)
DerivingInstance (template)

Content
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
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258

-- auxiliary template functions
module Prelude.Template (
  GetTypeVartemplate `Prelude.Template.GetTypeVar`
   argument-type: Nat
   return-type: String
   does not compute text,
  GetTypeVarstemplate `Prelude.Template.GetTypeVars`
   argument-type: Nat
   return-type: [String]
   does not compute text,
  GetTypeVarsNumberedtemplate `Prelude.Template.GetTypeVarsNumbered`
   argument-types: (String, Nat)
   return-type: [String]
   does not compute text,
  Intercalatetemplate `Prelude.Template.Intercalate`
   argument-types: (String, [String])
   return-type: String
   does not compute text,
  Commafytemplate `Prelude.Template.Commafy`
   argument-type: [String]
   return-type: String
   does not compute text,
  BuildTupletemplate `Prelude.Template.BuildTuple`
   argument-type: [String]
   return-type: String
   does not compute text,
  BuildTupleLefttemplate `Prelude.Template.BuildTupleLeft`
   argument-type: [String]
   return-type: String
   does not compute text,
  BuildTupleRighttemplate `Prelude.Template.BuildTupleRight`
   argument-type: [String]
   return-type: String
   does not compute text,
  BuildInstanceHeadertemplate `Prelude.Template.BuildInstanceHeader`
   argument-types: ([String], String)
   return-type: -,
  BuildInstancetemplate `Prelude.Template.BuildInstance`
   argument-types: ([String], String, String)
   return-type: -,
  GenerateRecogniserstemplate `Prelude.Template.GenerateRecognisers`
   argument-type: TypeID
   return-type: -,

  IsSimpleEnumDatatypetemplate `Prelude.Template.IsSimpleEnumDatatype`
   argument-type: TypeID
   return-type: Bool
   does not compute text,

  ConstWithArgstemplate `Prelude.Template.ConstWithArgs`
   argument-types: (Bool, String, ConstID)
   return-types: ([String], String)
   does not compute text,
  TypeWithArgstemplate `Prelude.Template.TypeWithArgs`
   argument-types: (Bool, TypeID)
   return-types: ([String], String)
   does not compute text,
  ClassWithArgstemplate `Prelude.Template.ClassWithArgs`
   argument-types: (Bool, ClassID)
   return-types: ([String], String)
   does not compute text,
  ConstWithWildcardArgstemplate `Prelude.Template.ConstWithWildcardArgs`
   argument-types: (Bool, ConstID)
   return-type: String
   does not compute text,

  DeriveInstanceComputeSuperDefaulttemplate `Prelude.Template.DeriveInstanceComputeSuperDefault`
   argument-types: (ClassID, TypeID)
   return-types: ([String], String, [String])
   does not compute text,
  DeriveInstancetemplate `Prelude.Template.DeriveInstance`
   argument-types: (ClassID, TypeID, TemplateID(ClassID -> TypeID -> ([String], String, [String])), TemplateID(ClassID -> TypeID -> [String] -> Text))
   return-type: -,
  DerivingInstancetemplate `Prelude.Template.DerivingInstance`
   argument-types: (ClassID, TypeID, [String], [String], String, TemplateID(ClassID -> TypeID -> [String] -> Text))
   return-type: -
) where

{-# NoImplicitPrelude #-}

-- generate the type variable with given number 'a, 'b, 'c, ...
template GetTypeVar (n :: Nat) :: String := {{
  var cntemplate-variable `cn`
   type Nat := ntemplate-variable `n`
   type Nat % 26;
  ntemplate-variable `n`
   type Nat := ntemplate-variable `n`
   type Nat / 26;
  var resulttemplate-variable `result`
   type String := "\'" ++ chr(cntemplate-variable `cn`
   type Nat + 97);
  if (ntemplate-variable `n`
   type Nat == 0) {
    return resulttemplate-variable `result`
   type String;
  } else {
    return (resulttemplate-variable `result`
   type String ++ ntemplate-variable `n`
   type Nat);
  }
}}

-- generate a list of type variable of given length, 'a, 'b, ...
template GetTypeVars (n :: Nat) :: [String] := {{
  var resulttemplate-variable `result`
   type [String] := [] :: [String];
  for var ytemplate-variable `y`
   type Nat := 1 to ntemplate-variable `n`
   type Nat {
    resulttemplate-variable `result`
   type [String] := insertAtEnd(!GetTypeVartemplate `Prelude.Template.GetTypeVar`
   argument-type: Nat
   return-type: String
   does not compute text(ytemplate-variable `y`
   type Nat-1), resulttemplate-variable `result`
   type [String]);
  };
  return resulttemplate-variable `result`
   type [String];
}}

-- generate a list of type variable of given length, 'p1, 'p2, ...
template GetTypeVarsNumbered (p :: String, n :: Nat) :: [String] := {{
  var resulttemplate-variable `result`
   type [String] := [] :: [String];
  for var ytemplate-variable `y`
   type Nat := 1 to ntemplate-variable `n`
   type Nat {
    var vntemplate-variable `vn`
   type String := "'" ++ ptemplate-variable `p`
   type String ++ ytemplate-variable `y`
   type Nat;
    resulttemplate-variable `result`
   type [String] := insertAtEnd(vntemplate-variable `vn`
   type String, resulttemplate-variable `result`
   type [String]);
  };
  return resulttemplate-variable `result`
   type [String];
}}


template Intercalate (sep :: String, s :: [String]) :: String := {{
  if (stemplate-variable `s`
   type [String].length == 0) {
    return ""
  } else {
    var resulttemplate-variable `result`
   type String := stemplate-variable `s`
   type [String][0];
    for var itemplate-variable `i`
   type Nat := 1 to (stemplate-variable `s`
   type [String].length - 1) {
      resulttemplate-variable `result`
   type String := resulttemplate-variable `result`
   type String ++ septemplate-variable `sep`
   type String ++ stemplate-variable `s`
   type [String][itemplate-variable `i`
   type Nat];
    };
    return resulttemplate-variable `result`
   type String;
  }
}}

-- commafy an array of strings and return the resulting string
template Commafy (s :: [String]) :: String := {{
  return !Intercalatetemplate `Prelude.Template.Intercalate`
   argument-types: (String, [String])
   return-type: String
   does not compute text(", ", stemplate-variable `s`
   type [String])
}}

-- commafy an array and also add parenthesis around it, i.e. it creates a tuple
template BuildTuple (s :: [String]) :: String := {{
  if (stemplate-variable `s`
   type [String].length == 0) {
    error("tuples should contain at least one element");
    return "error";
  } else-if (stemplate-variable `s`
   type [String].length == 1) {
    return stemplate-variable `s`
   type [String][0];
  } else {
    return ("(" ++ !Commafytemplate `Prelude.Template.Commafy`
   argument-type: [String]
   return-type: String
   does not compute text(stemplate-variable `s`
   type [String]) ++ ")");
  }
}}

-- creates a left-leaning tuple, i.e something like (((a, b), c), d)
template BuildTupleLeft (s :: [String]) :: String := {{
  if (stemplate-variable `s`
   type [String].length == 0) {
    error("tuples should contain at least one element");
    return "error";
  } else-if (stemplate-variable `s`
   type [String].length == 1) {
    return stemplate-variable `s`
   type [String][0];
  } else {
    var restemplate-variable `res`
   type String := stemplate-variable `s`
   type [String][0];
    for var itemplate-variable `i`
   type Nat := 1 to (stemplate-variable `s`
   type [String].length - 1) {
      restemplate-variable `res`
   type String := "(" ++ restemplate-variable `res`
   type String ++ ", " ++ stemplate-variable `s`
   type [String][itemplate-variable `i`
   type Nat] ++")";
    }
    return restemplate-variable `res`
   type String;
  }
}}


-- creates a right-leaning tuple, i.e something like (a, (b, (c, d)))
template BuildTupleRight (s :: [String]) :: String := {{
  if (stemplate-variable `s`
   type [String].length == 0) {
    error("tuples should contain at least one element");
    return "error";
  } else-if (stemplate-variable `s`
   type [String].length == 1) {
    return stemplate-variable `s`
   type [String][0];
  } else {
    var restemplate-variable `res`
   type String := stemplate-variable `s`
   type [String][stemplate-variable `s`
   type [String].length - 1];
    for var itemplate-variable `i`
   type Nat := (stemplate-variable `s`
   type [String].length - 2) downto 0 {
      restemplate-variable `res`
   type String := "(" ++ stemplate-variable `s`
   type [String][itemplate-variable `i`
   type Nat] ++ ", " ++ restemplate-variable `res`
   type String ++")";
    }
    return restemplate-variable `res`
   type String;
  }
}}


template IsSimpleEnumDatatype (ty :: TypeID) :: Bool := {{
  if (not (tytemplate-variable `ty`
   type TypeID.typeVariety == "datatype")) return False;

  foreach var ctemplate-variable `c`
   type ConstID in tytemplate-variable `ty`
   type TypeID.constructors {
    if (ctemplate-variable `c`
   type ConstID.argsNo > 0) return False;
  }
  if (tytemplate-variable `ty`
   type TypeID.constructors.length == 0) return False;

  return True;
}}


-- | add all the arguments separated by space to a base.
template AddArgs (forceParens :: Bool, base :: String, args :: [String]) :: String := {{
  var restemplate-variable `res`
   type String := basetemplate-variable `base`
   type String;
  foreach var argtemplate-variable `arg`
   type String in argstemplate-variable `args`
   type [String] {
    restemplate-variable `res`
   type String := restemplate-variable `res`
   type String ++ " " ++ argtemplate-variable `arg`
   type String;
  }
  if ((argstemplate-variable `args`
   type [String].length > 0) && forceParenstemplate-variable `forceParens`
   type Bool) {
    restemplate-variable `res`
   type String := "("++restemplate-variable `res`
   type String++")";
  }
  return restemplate-variable `res`
   type String
}}

-- | add the appropriate number of wildcard arguments to a constant and return
-- the resulting string. If at least one argument is used and if the parameter
-- 'forceParens' is set, parenthesis are added around the result
template ConstWithWildcardArgs (forceParens :: Bool, c :: ConstID) :: String := {{
  var argstemplate-variable `args`
   type [String] := replicate(ctemplate-variable `c`
   type ConstID.argsNo, "_");
  return (!AddArgstemplate `Prelude.Template.AddArgs`
   argument-types: (Bool, String, [String])
   return-type: String
   does not compute text(forceParenstemplate-variable `forceParens`
   type Bool, ctemplate-variable `c`
   type ConstID, argstemplate-variable `args`
   type [String]));
}}


-- | add the appropriate number of arguments to a constant and return
-- the added arguments as well as the resulting string. The names of the
-- arguments are generated using the given prefix.
-- If at least one argument is used and if the parameter
-- 'forceParens' is set, parenthesis are added around the result
template ConstWithArgs (forceParens :: Bool, prefix :: String, c :: ConstID) :: ([String], String) := {{
  var argstemplate-variable `args`
   type [String] := generateNames(prefixtemplate-variable `prefix`
   type String, ctemplate-variable `c`
   type ConstID.argsNo);
  return (argstemplate-variable `args`
   type [String], !AddArgstemplate `Prelude.Template.AddArgs`
   argument-types: (Bool, String, [String])
   return-type: String
   does not compute text(forceParenstemplate-variable `forceParens`
   type Bool, ctemplate-variable `c`
   type ConstID, argstemplate-variable `args`
   type [String]));
}}


-- | add the appropriate number of arguments to a type and return
-- the added arguments as well as the resulting string. The names of the
-- arguments are take from the definition of the type.
-- If at least one argument is used and if the parameter
-- 'forceParens' is set, parenthesis are added around the result
template TypeWithArgs (forceParens :: Bool, ty :: TypeID) :: ([String], String) := {{
  var argstemplate-variable `args`
   type [String] := tytemplate-variable `ty`
   type TypeID.args;
  return (argstemplate-variable `args`
   type [String], !AddArgstemplate `Prelude.Template.AddArgs`
   argument-types: (Bool, String, [String])
   return-type: String
   does not compute text(forceParenstemplate-variable `forceParens`
   type Bool, tytemplate-variable `ty`
   type TypeID, argstemplate-variable `args`
   type [String]));
}}

-- | build recognisers for all constructors of a data-type
template GenerateRecognisers (ty :: TypeID) := '''
{{ var (_, tyFulltemplate-variable `tyFull`
   type String) := !TypeWithArgstemplate `Prelude.Template.TypeWithArgs`
   argument-types: (Bool, TypeID)
   return-types: ([String], String)
   does not compute text(False, tytemplate-variable `ty`
   type TypeID) }}
{{% foreach var constrtemplate-variable `constr`
   type ConstID in tytemplate-variable `ty`
   type TypeID.constructors %}}
{{ var nametemplate-variable `name`
   type String := "is" ++ constrtemplate-variable `constr`
   type ConstID;
   var constrWithWctemplate-variable `constrWithWc`
   type String := !ConstWithWildcardArgstemplate `Prelude.Template.ConstWithWildcardArgs`
   argument-types: (Bool, ConstID)
   return-type: String
   does not compute text(True, constrtemplate-variable `constr`
   type ConstID)}}
declare {{= nametemplate-variable `name`
   type String =}} :: {{=tyFulltemplate-variable `tyFull`
   type String=}} -> Bool
define {{= nametemplate-variable `name`
   type String =}} {{= constrWithWctemplate-variable `constrWithWc`
   type String =}} := True
     | {{= nametemplate-variable `name`
   type String =}} _ := False

{{% end-foreach %}}
'''


-- | add the appropriate number of arguments to a type and return
-- the added arguments as well as the resulting string. The names of the
-- arguments are take from the definition of the class.
-- If at least one argument is used and if the parameter
-- 'forceParens' is set, parenthesis are added around the result
template ClassWithArgs (forceParens :: Bool, cl :: ClassID) :: ([String], String) := {{
  var argstemplate-variable `args`
   type [String] := cltemplate-variable `cl`
   type ClassID.args;
  return (argstemplate-variable `args`
   type [String], !AddArgstemplate `Prelude.Template.AddArgs`
   argument-types: (Bool, String, [String])
   return-type: String
   does not compute text(forceParenstemplate-variable `forceParens`
   type Bool, cltemplate-variable `cl`
   type ClassID, argstemplate-variable `args`
   type [String]));
}}



-- | given a list of super-constraints and the main instance, build the instance-header string
template BuildInstanceHeader (super :: [String], inst :: String) := '''
{{ var superStemplate-variable `superS`
   type String := "";
   if (supertemplate-variable `super`
   type [String].length > 0) {
     superStemplate-variable `superS`
   type String := !BuildTupletemplate `Prelude.Template.BuildTuple`
   argument-type: [String]
   return-type: String
   does not compute text(supertemplate-variable `super`
   type [String]) ++ " => ";
   }
}}
instance {{= superStemplate-variable `superS`
   type String =}}{{= insttemplate-variable `inst`
   type String =}} where
'''

-- | call 'BuildInstanceHeader' followed by a body and the end-instance
template BuildInstance (super :: [String], inst :: String, body :: String) := '''
{{! BuildInstanceHeadertemplate `Prelude.Template.BuildInstanceHeader`
   argument-types: ([String], String)
   return-type: -(supertemplate-variable `super`
   type [String], insttemplate-variable `inst`
   type String) !}}
  {{= bodytemplate-variable `body`
   type String =}}
end-instance
'''

-- | Auxliary template for building instances of type-classes. Given a type-class with
-- exactly one argument and a type-ID to use for this argument, it looks up the arguments
-- of the type and uses each found argument with the main type-class as a class constraint of this instance.
-- This is useful for defining instances of classes like Eq automatically.
-- It returns the super-constraints, the instance as well as the full type and the used type args
template DeriveInstanceComputeSuperDefault (cl :: ClassID, ty :: TypeID) :: ([String], String, [String]) := {{
  if (not (cltemplate-variable `cl`
   type ClassID.argsNo == 1)) error("only type-classes with 1 argument supported");

  var (tyArgstemplate-variable `tyArgs`
   type [String], tyFulltemplate-variable `tyFull`
   type String) := !TypeWithArgstemplate `Prelude.Template.TypeWithArgs`
   argument-types: (Bool, TypeID)
   return-types: ([String], String)
   does not compute text(True, tytemplate-variable `ty`
   type TypeID);
  var insttemplate-variable `inst`
   type String := cltemplate-variable `cl`
   type ClassID ++ " " ++ tyFulltemplate-variable `tyFull`
   type String;

  var supertemplate-variable `super`
   type [String] := [] :: [String];
  foreach var ttemplate-variable `t`
   type String in tyArgstemplate-variable `tyArgs`
   type [String] {
    supertemplate-variable `super`
   type [String] := insertAtEnd(cltemplate-variable `cl`
   type ClassID ++ " " ++ ttemplate-variable `t`
   type String, supertemplate-variable `super`
   type [String]);
  }

  return (supertemplate-variable `super`
   type [String], insttemplate-variable `inst`
   type String, tyArgstemplate-variable `tyArgs`
   type [String]);
}}

-- | the build-in template used for "derive" statements. It gets a template to compute the class constraints and
-- the instance and a template to compute the body. If for a type-class no other template is registered,
-- 'DeriveInstanceComputeSuperDefault' is used automatically
template DeriveInstance (cl :: ClassID, ty :: TypeID,
   superInst :: TemplateID(ClassID -> TypeID -> ([String], String, [String])),
   body :: TemplateID(ClassID -> TypeID -> [String] -> Text)) := '''
{{ var (supertemplate-variable `super`
   type [String], insttemplate-variable `inst`
   type String, tyArgstemplate-variable `tyArgs`
   type [String]) := !superInsttemplate-variable `superInst`
   type TemplateID(ClassID -> TypeID -> ([String], String, [String]))(cltemplate-variable `cl`
   type ClassID, tytemplate-variable `ty`
   type TypeID); }}
{{! DerivingInstancetemplate `Prelude.Template.DerivingInstance`
   argument-types: (ClassID, TypeID, [String], [String], String, TemplateID(ClassID -> TypeID -> [String] -> Text))
   return-type: - (cltemplate-variable `cl`
   type ClassID, tytemplate-variable `ty`
   type TypeID, tyArgstemplate-variable `tyArgs`
   type [String], supertemplate-variable `super`
   type [String], insttemplate-variable `inst`
   type String, bodytemplate-variable `body`
   type TemplateID(ClassID -> TypeID -> [String] -> Text)) !}}
'''

-- | the build-in template used for "derivig" statements.
template DerivingInstance (cl :: ClassID, ty :: TypeID, tyArgs :: [String], super :: [String], inst :: String, body :: TemplateID(ClassID -> TypeID -> [String] -> Text)) := '''
{{! BuildInstanceHeadertemplate `Prelude.Template.BuildInstanceHeader`
   argument-types: ([String], String)
   return-type: -(supertemplate-variable `super`
   type [String], insttemplate-variable `inst`
   type String) !}}
  {{= !bodytemplate-variable `body`
   type TemplateID(ClassID -> TypeID -> [String] -> Text)(cltemplate-variable `cl`
   type ClassID, tytemplate-variable `ty`
   type TypeID, tyArgstemplate-variable `tyArgs`
   type [String]) =}}
end-instance
'''


end-moduleend of module Prelude.Template