Source

GTALib / src / GTA / Util / GenericSemiringStructureTemplate.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
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
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
{-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,TemplateHaskell  #-}

{-| This module provides a mechanism for automatic generation of data-structure-dependent definitions necessary for the GTA framework (namely, an instance of 'GTA.Core.GenericSemiringStructure' as well as definitions of algebras and structures for map functions). 
-}
module GTA.Util.GenericSemiringStructureTemplate (genAlgebraDecl, genMapFunctionsDecl, genInstanceDecl, genAllDecl) where

import Language.Haskell.TH
import GTA.Util.TypeInfo 
import Data.Char
{-
reference: 
 http://www.haskell.org/haskellwiki/Template_haskell/Instance_deriving_example
-}

{- exported functions -}
{-| This function generates a definition of the algebra of a given data structure. For example, given a data structure defined below,

> data BinTree n l = BinNode n (BinTree n l) (BinTree n l)
>                  | BinLeaf l

the following definition of the algebra is generated by @genAlgebraDecl ''BinTree@.

> data BinTreeAlgebra n l a = BinTreeAlgebra {
>       binNode :: n -> a -> a -> a,
>       binLeaf :: l -> a
>     }

-}
genAlgebraDecl :: Name -> Q [Dec]
genAlgebraDecl typName =
  do (typeName,typeParams,constructors) <- typeInfo typName
     alg <- genAlgebraRecord typeName typeParams constructors
     return ([alg])

{-| This function generates a definition of a record holding functions to be mapped to values in a given data structure. For example, given a data structure defined below,

> data BinTree n l = BinNode n (BinTree n l) (BinTree n l)
>                  | BinLeaf l
 
the following record is generated by @genMapFunctionsDecl ''BinTree@.

> data BinTreeMapFs n l b' = BinTreeMapFs {
>       binNodeF :: n -> b',
>       binLeafF :: l -> b'
>     }
 
-}
genMapFunctionsDecl :: Name -> Q [Dec]
genMapFunctionsDecl typName =
  do (typeName,typeParams,constructors) <- typeInfo typName
     alg <- genMapFunctionsRecord typeName typeParams constructors
     return ([alg])

{-| This function generates an instance of 'GTA.Data.GenericSemiringStructure' for a given data structure. For example, given a data structure defined below,

> data BinTree n l = BinNode n (BinTree n l) (BinTree n l)
>                  | BinLeaf l
 
the following record is generated by @genInstanceDecl''BinTree@.

> instance GenericSemiringStructure (BinTreeAlgebra n l) (BinTree n l) (BinTreeMapFs n l) where
>   freeAlgebra = BinTreeAlgebra {..} where
>       binNode = BinNode
>       binLeaf = BinLeaf
>   pairAlgebra lvta1 lvta2 = BinTreeAlgebra {..} where
>       binNode a (l1, l2) (r1, r2) = (binNode1 a l1 r1, binNode2 a l2 r2)
>       binLeaf a                   = (binLeaf1 a, binLeaf2 a)
>       (binNode1, binLeaf1) = let BinTreeAlgebra {..} = lvta1 in (binNode, binLeaf)
>       (binNode2, binLeaf2) = let BinTreeAlgebra {..} = lvta2 in (binNode, binLeaf)
>   makeAlgebra (CommutativeMonoid {..}) lvta frec fsingle = BinTreeAlgebra {..} where  
>       binNode a l r = foldr oplus identity [fsingle (binNode' a l' r') | l' <- frec l, r' <- frec r]
>       binLeaf a     = fsingle (binLeaf' a)
>       (binNode', binLeaf') = let BinTreeAlgebra {..} = lvta in (binNode, binLeaf)
>   foldingAlgebra op iop (BinTreeMapFs {..}) = BinTreeAlgebra {..} where
>       binNode a l r = binNodeF a `op` l `op` r
>       binLeaf a     = binLeafF a
>   hom (BinTreeAlgebra {..}) = h where
>       h (BinNode a l r) = binNode a (h l) (h r)
>       h (BinLeaf a)     = binLeaf a
> 

-}
genInstanceDecl :: Name -> Q [Dec]
genInstanceDecl typName =
  do (typeName,typeParams,constructors) <- typeInfo typName
     inst <- genSemiringInstance typeName typeParams constructors
     return ([inst])

{-| Given a data structure, this function generates a definition of its algebra (by @genAlgebraDecl@), a record of map functions (by @genMapFunctionsDecl@), and an instance of 'GTA.Data.GenericSemiringStructure' (by @genInstanceDecl@). Usage: @genAllDecl ''BinTree@.
-}
genAllDecl :: Name -> Q [Dec]
genAllDecl typName =
  do alg <- genAlgebraDecl typName
     mf <- genMapFunctionsDecl typName
     inst <- genInstanceDecl typName
     return (alg ++ mf ++ inst)

{-
Given a data type like
 data BTree a = Node a (BTree a) (BTree a)
              | Leaf a
, this generates a record type corresponding to the algebra like
 data BTreeAlgebra b a = 
   BTreeAlgebra {
     node :: b -> a -> a -> a,
     leaf :: b -> a
   }
.
-}
genAlgebraRecord :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genAlgebraRecord typeName typeParams constructors = 
  let a = mkName "gta"
      newParams = typeParams++[PlainTV a]
      dataName = algebraName typeName
      funs = map genFun constructors -- functions corresponding to constructors
      con = recC dataName funs -- the constructor = the name
      genFun (name, params) = 
        varStrictType (funcName name) 
        (strictType notStrict (arrowConcat (map (\(VarT a) -> varT a) (replace freeType (VarT a) (map (\(_, t) -> t) params ++[VarT a])))))
      freeType = genFreeType typeName typeParams
  in dataD (cxt []) dataName newParams [con] []

{-
data BTreeMapFs b b' = BTreeMapFs {
         nodeF :: (b -> b'),
         leafF :: (b -> b')
       }
This is a set of functions to make types of values the same.
-}
genMapFunctionsRecord :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genMapFunctionsRecord typeName typeParams constructors = 
  let a = mkName "gta"
      newParams = typeParams++[PlainTV a]
      mapName = mapFunctionsName typeName
      funs = map genFun constructors' -- functions corresponding to constructors
      con = recC mapName funs -- the constructor = the name
      funcName' = mfFuncName . funcName
      constructors' = filter (\(_, x) -> length x > 0) (map dropFreeType constructors)
      dropFreeType (name, params) = (name, filter (/=freeType) (map (\(_, t) -> t) params))
      genFun (name, params) = 
        varStrictType (funcName' name) 
        (strictType notStrict (mkTupleType (map (\(VarT b) -> appT (appT arrowT (varT b)) (varT a)) params)))
      freeType = genFreeType typeName typeParams
  in dataD (cxt []) mapName newParams [con] []
     
mkTupleType :: [TypeQ] -> TypeQ
mkTupleType [a] = a
mkTupleType x = foldl appT (tupleT (length x)) x
{-
  instance GenericSemiringStructure (BTreeAlgebra b) (BTree b) (BTreeMapFs b) where
-}
genSemiringInstance :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genSemiringInstance typeName typeParams constructors = 
  let className = mkName "GenericSemiringStructure" 
      appfold e = foldl appT e . map (\(PlainTV a) -> varT a) 
      instanceType = appT (appT (appT (conT className) (appfold (conT dataName) typeParams)) (appfold (conT typeName) typeParams)) (appfold (conT mapName) typeParams)
      dataName = algebraName typeName
      mapName = mapFunctionsName typeName
--      funcs = [genBagFreeAlgebra typeName typeParams constructors,
--               genLiftedAlgebra typeName typeParams constructors,
--               genHom typeName typeParams constructors]
      funcs = [genFreeAlgebra typeName typeParams constructors,
               genHom typeName typeParams constructors,
               genPairAlgebra typeName typeParams constructors,
               genMakeAlgebra typeName typeParams constructors,
               genFoldingAlgebra typeName typeParams constructors]
  in instanceD (cxt []) instanceType funcs

{-
  freeAlgebra = BTreeAlgebra {..} where
     node = Node
     leaf = Leaf
-}
genFreeAlgebra :: forall t t1. Name -> t -> [(Name, t1)] -> DecQ
genFreeAlgebra typeName _ constructors = 
  let
    freeAlgebraName = (mkName "freeAlgebra")
    fieldEs = genWildcardFieldExp (map (\(n, _) -> funcName n) constructors)
    e = recConE (algebraName typeName) fieldEs
    decls = map genFunDecl constructors
    genFunDecl (n, _) = funD (funcName n) [clause [] (normalB (conE n)) []]
  in funD freeAlgebraName [clause [] (normalB e) decls]

{-
  pairAlgebra bt1 bt2 = BTreeAlgebra {..} 
    where
      node a (l1, l2) (r1, r2) = (node1 a l1 r1, node2 a l2 r2)
      leaf a = (leaf1 a, leaf2 a)
      (leaf1, node1) = let BTreeAlgebra {..} = bt1 in (leaf, node)
      (leaf2, node2) = let BTreeAlgebra {..} = bt2 in (leaf, node)
-}
genPairAlgebra :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genPairAlgebra typeName typeParams constructors = 
  let
    alg1 = mkName "algebra1"
    alg2 = mkName "algebra2"
    vps = map varP [alg1, alg2]
    fs = map (\(n, _)->funcName n) constructors
    binds = [recBind (algebraName typeName) fs (varE alg1) (name 1),
             recBind (algebraName typeName) fs (varE alg2) (name 2)]
    name i = mkName . (++show i) . nameBase
    bindExp ve = ve
    bindPat a = tupP [varP (name 1 a), varP (name 2 a)]
    newAlgebraName = (mkName "pairAlgebra")
    genBody _ n' pbs = tupE [foldl1 appE (varE (name 1 n'):vars 1), foldl1 appE (varE (name 2 n'):vars 2)]
      where
        varnames f = map (\(b, VarT a) -> case b of Just (VarT c) -> f c
                                                    otherwise -> a) pbs
        vars i = map varE (varnames (name i))
  in genAlgebraDec' typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genBody

{-
  makeAlgebra (CommutativeMonoid {..}) bt frec fsingle = BTreeAlgebra {..}
    where  
    node a l r = foldr oplus identity [fsingle (node' a l' r') | l' <- frec l, r' <- frec r]
    leaf a = fsingle (leaf' a)
    (leaf', node') = let BTreeAlgebra {..} = bt in (leaf, node)

-}
genMakeAlgebra :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genMakeAlgebra typeName typeParams constructors = 
  let
    m = mkName "m"
    alg = mkName "alg"  
    frec = mkName "frec"
    fsingle = mkName "fsingle"
    vps = map varP [m, alg, frec, fsingle]
    fs = map (\(n, _)->funcName n) constructors
    binds = [recBind (algebraName typeName) fs (varE alg) name,
             monoidBind (varE m)]
    name = mkName . (++"gta") . nameBase
    bindExp ve = appE (varE frec) ve
    bindPat a = varP a
    newAlgebraName = (mkName "makeAlgebra")
    genComprBody _ n' pbs = appE (varE fsingle) (foldl1 appE (varE (name n'):vars))
      where vars = map (\(b, VarT a) -> case b of Just (VarT c) -> varE c
                                                  otherwise -> varE a) pbs
  in genAlgebraDec typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genComprBody

{-
  foldingAlgebra op iop (BTreeMapFs {..}) = BTreeAlgebra {..}
    where
    node a l r = nodeF a `op` l `op` r
    leaf a = leafF a
-}
genFoldingAlgebra :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genFoldingAlgebra typeName typeParams constructors = 
  let
    mf = mkName "mf"
    op = mkName "op"
    iop = mkName "iop"
    vps = map varP [op, iop, mf]
    constructors' = filter hasNonRec constructors
    hasNonRec (_, ps) = length (filter (\(_, t) -> t /=freeType) ps) > 0
    fs = map (\(n, _)->mfFuncName(funcName n)) constructors'
    binds = [recBind (mapFunctionsName typeName) fs (varE mf) id]
    freeType = genFreeType typeName typeParams
    newAlgebraName = (mkName "foldingAlgebra")
    funcs _ n' pbs = let 
        nonrecs = map (\(b, VarT _) -> case b of Just (VarT _) -> 0
                                                 otherwise -> 1) pbs
        ids = tail(scanl (+) 0 nonrecs)
        f 0 _ a = Left a
        f 1 i b = Right (name i (mfFuncName n'), b)
        in zipWith3 f nonrecs ids pbs        
    name i =  mkName . (++show i) . nameBase
    genVarbinds n n' pbs = 
        let funs = funcs n n' pbs
            ns = map (\(Right (n, _)) -> varP n) (filter fr funs)
            fr (Left _) = False
            fr (Right _) = True
        in if length ns == 0 then [] else [valD (tupP ns) (normalB (varE (mfFuncName n'))) []]
    genBody n n' pbs = if pbs == [] then varE iop else foldl1 (\a b -> appE (appE (varE op) a) b) vars
      where
        funs = funcs n n' pbs
        vars = map f funs
        f (Left (_, VarT a)) = varE a
        f (Right (fn, (_, VarT a))) = appE (varE fn) (varE a)
  in genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds



{-  
hom (BTreeBAlgebra {..}) = h
  where
    h (NodeB a l r) = nodeB a (h l) (h r)
    h (LeafB a) = leafB a
-}
genHom :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genHom typeName typeParams constructors = 
  let
    fs = map (\(n, _)->funcName n) constructors
    vps = [recPat (algebraName typeName) fs id]
    freeType = genFreeType typeName typeParams
    decls = [funD h (map genClause constructors)]
    h = mkName "h"
    genClause (n, ps) = let
      n' = funcName n
      ts = map (\(_, t) -> t) ps
      pbs = zipWith mkpb ts (newVars "rv")
      mkpb t v = if t == freeType then (Just (), v) else (Nothing, t)
      pats = [conP n (map (\(_, VarT a) -> varP a) pbs)]
      subes = map (\(b, VarT a) -> case b of Just () -> appE (varE h) (varE a)
                                             otherwise -> varE a) pbs
      b = foldl appE (varE n') subes
      in clause pats (normalB b) []
  in funD (mkName "hom") [clause vps (normalB (varE h)) decls]

{-
TODO: this function has been split into several parts. write comments!

e.g., to generate the following (obsolete, though),

  liftedAlgebra bts bt = BTreeAlgebra {..}
    where  
      node a l r = 
        foldr oplus identity [singleton (nodebt a kll krr) (nodebt' a vll vrr) | (kll, vll) <- assocs l, (krr, vrr) <- assocs r]
      leaf a = singleton (leafbt a) (leafbt' a)
      CommutativeMonoid {..} = mapMonoid (monoid bts)
      (leafbt, nodebt) = let BTreeAlgebra {..} = bt in (leaf, node)
      (leafbt', nodebt') = let BTreeAlgebra {..} = algebra bts in (leaf, node)

the function arguments are
 - (typeName, typeParams, constructors) is of typeInfo ''BTree
 - binds is a list of valDs for    
      CommutativeMonoid {..} = mapMonoid (monoid bts)
      (leafbt, nodebt) = let BTreeAlgebra {..} = bt in (leaf, node)
      (leafbt', nodebt') = let BTreeAlgebra {..} = algebra bts in (leaf, node)
 - newAlgebraName is 'liftedAlgebra'
 - vps is a list of argument patterns of the 'liftedAlgebra', i.e., [bts, bt] 
 - bindExp generates expressions (RHS of <-) of binds in the comprehension, 
   i.e., bindExp v = assocs v
 - bindPat generates patterns (LHS of <-) of binds in the comprehension,
   i.e., bindPat r = (kr, vr)
 - genComprBody generates the body of the comprehention from 
     n   ... the constructor name
     n'  ... the function name corresponding to the constructor
     pbs ... a list of (Maybe Type, Type) generated from the constructor's type 
               Here, each value of Type is of VarT x.
               If the variable has the same type as the data structure,
                the first part is Just (VarT y) 
                s.t. a bind "bindPat y <- bindExp x" is generated.
               Otherwise it is Nothing.
               For Node of BTree, pbs = [(Nothing, VarT a), 
                                         (Just (VarT ll), VarT l),
                                         (Just (VarT rr), VarT r)]
-}
genAlgebraDec :: forall t.
                     Name
                     -> [TyVarBndr]
                     -> [(Name, [(t, Type)])]
                     -> [DecQ]
                     -> Name
                     -> [PatQ]
                     -> (ExpQ -> ExpQ)
                     -> (Name -> PatQ)
                     -> (Name -> Name -> [(Maybe Type, Type)] -> ExpQ)
                     -> DecQ
genAlgebraDec typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genComprBody = 
  let
    genVarbinds _ _ _ = []
    genBody n n' pbs =
          if and (map ((==Nothing).fst) pbs) 
          then -- has no recursive position 
              genComprBody n n' pbs                    
          else -- has recursive positions
              let 
                  bigOp = foldl1 appE (map (varE.mkName) ["foldr", "oplus", "identity"])
                  
                  varbinds = map bind (filter ((/=Nothing).fst) pbs)
                  bind (Just(VarT a),VarT b) = bindS (bindPat a) (bindExp (varE b))
                  compr = compE (varbinds++[noBindS (genComprBody n n' pbs)])
              in appE bigOp compr
  in genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds

genAlgebraDec' :: forall t.
                     Name
                        -> [TyVarBndr]
                        -> [(Name, [(t, Type)])]
                        -> [DecQ]
                        -> Name
                        -> [PatQ]
                        -> (ExpQ -> ExpQ)
                        -> (Name -> PatQ)
                        -> (Name -> Name -> [(Maybe Type, Type)] -> ExpQ)
                        -> DecQ
genAlgebraDec' typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genBody = 
  let genVarbinds _ _ pbs = map bind (filter ((/=Nothing).fst) pbs)
        where bind (Just(VarT a),VarT b) = valD (bindPat a) (normalB (bindExp (varE b))) []
  in genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds

genAlgebraDec'' :: forall t.
                      Name
                          -> [TyVarBndr]
                          -> [(Name, [(t, Type)])]
                          -> [DecQ]
                          -> Name
                          -> [PatQ]
                          -> (Name -> Name -> [(Maybe Type, Type)] -> ExpQ)
                          -> (Name -> Name -> [(Maybe Type, Type)] -> [DecQ])
                          -> DecQ
genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds = 
    let fieldEs = genWildcardFieldExp (map (\(n, _) -> funcName n) constructors)
        e = recConE (algebraName typeName) fieldEs
        freeType = genFreeType typeName typeParams
        decls = map genFunDecl constructors ++ binds
        genFunDecl (n, ps) = 
          let n' = funcName n
              ts = map (\(_, t) -> t) ps
              pbs = zipWith3 mkpb ts (newVars "rv") (newVars "rvi")
              mkpb t v vv = if t == freeType then (Just vv, v) else (Nothing, t)
              pats = map (\(_, VarT a) -> varP a) pbs
              b = genBody n n' pbs
              varbinds = genVarbinds n n' pbs
          in funD n' [clause pats (normalB b) varbinds]
    in funD newAlgebraName [clause vps (normalB e) decls]

replace :: forall b. Eq b => b -> b -> [b] -> [b]
replace a b x = map (\c -> if c == a then b else c) x

arrowConcat :: [TypeQ] -> TypeQ
arrowConcat = foldr1 (\v x -> appT (appT arrowT v) x)

funcName :: Name -> Name
funcName = mkName . unCapalize . nameBase

unCapalize :: [Char] -> [Char]
unCapalize (x:y) = (toLower x):y

algebraName :: Name -> Name
algebraName typeName = mkName (nameBase typeName++"Algebra")

mapFunctionsName :: Name -> Name
mapFunctionsName typeName = mkName (nameBase typeName++"MapFs")

mfFuncName :: Name -> Name
mfFuncName = mkName . (++"F") . nameBase 

monoidBind :: ExpQ -> DecQ
monoidBind e = recBind (mkName "CommutativeMonoid") [mkName "oplus", mkName "identity"] e id

recBind :: Name -> [Name] -> ExpQ -> (Name -> Name) -> DecQ
recBind n fs e f = valD (recPat n fs f) (normalB e) []

recPat :: Name -> [Name] -> (Name -> Name) -> PatQ
recPat n fs f = recP n (genWildcardFieldPat f fs)

genFreeType :: Name -> [TyVarBndr] -> Type
genFreeType typeName typeParams = foldl1 AppT (ConT typeName:typeParams'')
  where typeParams'' = map (\(PlainTV a) -> VarT a) typeParams

genWildcardFieldExp :: [Name] -> [Q (Name, Exp)]
genWildcardFieldExp = map (\n -> fieldExp n (varE n)) 

genWildcardFieldPat :: (Name -> Name) -> [Name] -> [FieldPatQ]
genWildcardFieldPat f = map (\n -> fieldPat n (varP (f n))) 

newVars :: [Char] -> [Type]
newVars s = g 0 where g i = VarT (mkName (s ++ show i)) : g (i+1)