AspectAG 0.3.2 → 0.3.3

raw patch · 5 files changed

+339/−213 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• AspectAG.cabal +1/−1
• examples/Main.hs +0/−114
• examples/testList.hs +9/−7
• src/Language/Grammars/AspectAG.hs +230/−44
• src/Language/Grammars/AspectAG/Derive.hs +99/−47

@@ -1,5 +1,5 @@ name:               AspectAG -version:            0.3.2+version:            0.3.3 cabal-version:      >= 1.2.3   license:            LGPL license-file:       COPYRIGHT

@@ -1,114 +0,0 @@------------------------------------------------------------------------------------ Module      :  Main--- Copyright   :--- License     :  AllRightsReserved------ Maintainer  :--- Stability   :--- Portability :------ |----------------------------------------------------------------------------------{-# OPTIONS -fcontext-stack=100 #-}-{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}--module Main where---import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1---- data DefinitionList---    = DLCons { dlHd :: Definition, dlTl :: DefinitionList } | DLNil { dlNil :: () }---data Const-    =   ConstString String-    |   ConstInt    Int-    |   ConstChar   Char-    deriving(Show, Eq)--type WrapConst = Const-type StringList = [String]--$(typeList "EList" "Expression")-fromListEList = foldr ConsEList NilEList -- could be generated by typeList--data Definition-    =   Definition {-            dName       :: String-    ,       dArgs       :: StringList-    ,       dExpression :: Expression-    ,       dWhere      :: DefinitionList-    }  --type DefinitionList = [Definition]--data Expression-    =   Application { eFn :: Expression, eArgs :: EList }-    |   Atom { eAtom :: String }-    |   Lambda { eFormalArgs :: StringList, eBody :: Expression }-    |   Constant { eConst :: WrapConst }---$(deriveAG ''Definition)--$(attLabels ["xerror", "diLevel", "xerror2"])--{--processChildList children = map (\ex -> sem_Expression (asp_xerror ()) ex emptyRecord) children--processArgs eArgs = do-    return $ foldr (\x l -> "o" : (x # xerror) ++ l) [] $ processChildList eArgs--}--asp_xerrorD () = synAspect xerror (nt_Definition .*. nt_Expression .*. nt_EList .*. hNil)-        ((++)::[String] -> [String] -> [String])  ([]::[String])-        ( p_Application .*. p_Definition .*. p_Atom .*. p_Lambda .*. p_Constant .*. hNil ) $ -- use rule-        emptyRecord---- could also be generated by typeList-asp_foldrEList f s = synAspect xerror (nt_EList .*. nt_Expression .*. hNil)-                f  s-                (p_ConsEList .*. p_NilEList .*. hNil)-                emptyRecord---asp_xerror () = asp_xerrorD () .+. asp_foldrEList ((\lhd ltl -> "o" : lhd ++ ltl)::[String] -> [String] -> [String]) ([]::[String])--asp_xerror2 () = synAspect xerror2 (nt_Definition .*. nt_Expression .*. nt_EList .*. hNil)-        ((++)::[String] -> [String] -> [String])  ([]::[String])-        ( p_Application .*. p_Atom .*. p_Lambda .*. p_Constant .*. p_ConsEList .*. p_NilEList .*. hNil ) $ -- use rule-        p_Definition .=. (def $ at lhs >>= \lhs -> do return [show $ lhs # diLevel ]) .*.-        emptyRecord--{--asp_diLevel () = inhAspect diLevel ( nt_Expression .*. hNil ) ( p_Application .*. p_Lambda .*. hNil ) $-    p_Definition .=. (def $ at lhs >>= \lhs -> return $ (ch_dExpression .=. (lhs # diLevel) + 1) .*. emptyRecord)-    .*. emptyRecord--}---ex :: Expression-ex = Application (Lambda ["foo"] (Atom "x")) $ fromListEList $ map (Constant . ConstInt) [2, 2, 5]--dd = Definition {-        dName = "bar"-    ,   dArgs = ["x", "y"]-    ,   dExpression = ex-    ,   dWhere = []-    }--sem1 = sem_Definition (asp_xerror  ()) dd (diLevel .=. 55 .*. emptyRecord) # xerror-sem2 = sem_Definition (asp_xerror2 ()) dd (diLevel .=. 55 .*. emptyRecord) # xerror2--sem3 = sem_Definition (asp_xerror () .+. asp_xerror2 ())  dd (diLevel .=. 55 .*. emptyRecord) # xerror2--main = print sem1 >> print sem2 >> print sem3-

@@ -14,13 +14,14 @@  import Language.Haskell.TH  -$(typeList "EList" "Expression")+type EList = [Expression]+type MaybeInt = Maybe Int  data Expression     =   Application { eFn :: Expression, eArgs :: EList }     |   Atom { eAtom :: String }     |   Lambda { eFormalArgs :: [String], eBody :: Expression }-    |   Constant { eConst :: Int } +    |   Constant { eConst :: MaybeInt }    $(deriveAG ''Expression)@@ -31,15 +32,16 @@  -- counts the total number of 'eArgs' in an expression asp_cantArgs () = synAspect cantArgs allNT -                            ((+)::Int->Int->Int)  (0::Int) ( p_Application .*. p_Atom .*. p_Lambda .*. p_Constant .*. p_NilEList .*. hNil ) -- use rule-                            (   p_ConsEList .=. (def $ do  e  <- at ch_hdEList                     -                                                           es <- at ch_tlEList-                                                           return $ (e # cantArgs) + 1 + (es # cantArgs) )  -- add 1 for each element of the list+                            ((+)::Int->Int->Int)  (0::Int) ( p_Application .*. p_Atom .*. p_Lambda .*. p_Constant .*. p_EList_Nil .*. +                                                             p_MaybeInt_Just .*. p_MaybeInt_Nothing .*. hNil ) -- use rule+                            (   p_EList_Cons .=. (def $ do  e  <- at ch_hd_EList_Cons                     +                                                            es <- at ch_tl_EList_Cons+                                                            return $ (e # cantArgs) + 1 + (es # cantArgs) )  -- add 1 for each element of the list                             .*. emptyRecord )   -ex = Application (Lambda ["x","y"] (Atom "x")) (ConsEList (Constant 2) $ ConsEList (Constant 5) NilEList)+ex = Application (Lambda ["x","y"] (Atom "x")) [Constant Nothing, Application (Atom "y") [Constant $ Just 3] ]   main = sem_Expression (asp_cantArgs ()) ex emptyRecord # cantArgs    

@@ -35,7 +35,8 @@               inhmodM, synmodM,
 
               -- ** Rules Composition
-              ext, adapt, rename, fixCst, graft,
+              ext, adapt, rename, mapChildren, fixCst, graft,
+              macro, (==>),(-->), (<.>), 
 
               -- * Aspects
               Prd, (.+.),
@@ -303,6 +304,7 @@ instance RenLR HNil r r where
   renLR _ r = r           
 
+
 instance ( RenLR s (Record r') (Record r'') 
          , HRLabelSet (HCons (LVPair lr' v) r''), HasField lr r v, H2ProjectByLabels (HCons lr HNil) r t r')
          => RenLR    (HCons (LVPair lr lr')      s) 
@@ -323,6 +325,7 @@ 
 instance RenRL HNil r r where
   renRL _ r = r           
+
                      
 instance ( RenRL s (Record r') (Record r'') 
          , HRLabelSet (HCons (LVPair lr' v) r''), HasField lr r v, H2ProjectByLabels (HCons lr HNil) r t r')
@@ -339,6 +342,94 @@      r'' = renRL s r'
 
 
+-- | Children mapping.
+mapChildren :: (MapRL s sc' sc, MapRL s ici' ici, MapLR s ico ico')  
+     => Rule lf hof sc  ip li hoi ici  spi lo hoo ico  spo
+     -> s
+     -> Rule lf hof sc' ip li hoi ici' spi lo hoo ico' spo
+mapChildren asp s = adapt asp (mapRL s) (mapRL s) (mapLR s)  
+
+class MapLR s r r'  | s r -> r' where  
+  mapLR :: s -> r -> r'
+
+
+instance ( MapLR l r r') => MapLR (Record l) r r'
+         where
+  mapLR (Record l) r =  mapLR l r
+
+
+instance MapLR HNil r (Record HNil) where
+  mapLR _ _ = emptyRecord           
+
+
+instance ( MapLR s (Record r) (Record r'),
+           RecordLabels r' ls, HMember lr' ls b, 
+           MapLRB b (LVPair lr lr') (Record r) (Record r') (Record r''))
+         => MapLR    (HCons (LVPair lr lr')      s) 
+                     (Record r)
+                     (Record r'')
+         where
+  mapLR (HCons lp s) r =  mapLRB b lp r r'
+   where
+     lr' = valueLVPair lp
+     r'  = mapLR s r
+     b   = hMember lr' (recordLabels r')
+
+
+class MapLRB b s r r' r''  | b s r r' -> r'' where  
+  mapLRB :: b -> s -> r -> r' -> r''
+
+instance ( HRLabelSet (HCons (LVPair lr' v) r'), HasField lr r v)
+         => MapLRB   HFalse
+                     (LVPair lr lr') 
+                     (Record r)
+                     (Record r')
+                     (Record (HCons (LVPair lr' v) r'))
+         where
+  mapLRB _ lp r r' =  hExtend (newLVPair lr' v) r'
+   where
+     lr  = labelLVPair lp
+     lr' = valueLVPair lp
+     v   = hLookupByLabel lr r
+
+instance MapLRB   HTrue
+                     (LVPair lr lr')
+                     (Record r)
+                     (Record r')
+                     (Record r')
+         where
+  mapLRB _ _ _ r' =  r'
+
+
+
+class MapRL s r r'  | s r -> r' where  
+  mapRL :: s -> r -> r'
+
+instance ( MapRL l r r') => MapRL (Record l) r r'
+         where
+  mapRL (Record l) r =  mapRL l r
+
+
+instance MapRL HNil r (Record HNil) where
+  mapRL _ _ = emptyRecord
+
+                     
+instance ( MapRL s (Record r) (Record r') 
+         , HRLabelSet (HCons (LVPair lr' v) r'), HasField lr r v)
+         => MapRL    (HCons (LVPair lr' lr)      s) 
+                     (Record r) 
+                     (Record (HCons (LVPair lr' v) r'))
+         where
+  mapRL (HCons lp s) r =  hExtend (newLVPair lr' v) r'
+   where
+     lr' = labelLVPair lp
+     lr  = valueLVPair lp
+     v   = hLookupByLabel lr r
+     r'  = mapRL s r
+
+
+
+
 -- | Fixing a constant as a child.
 fixCst
   :: (RecordLabels r ls,
@@ -361,61 +452,155 @@                     ico' = hRearrange ls (hDeleteAtLabel lch ico)
                in   (Fam lo hoo ico' spo)
 
-
 -- | Grafting one tree as a child of the other.
-graft
-  :: (RecordLabels r ls,
-      RecordValues r1 vs,
-      HRLabelSet t2,
-      HRLabelSet t1,
-      H2ProjectByLabels vs r t1 t2,
-      HRLabelSet (HCons (LVPair l (Record HNil)) t2),
-      HRLabelSet t21,
-      HRLabelSet t11,
-      H2ProjectByLabels vs t t11 t21,
-      HasField l t6 ip1,
-      RenLR r1 ico1 t4,
-      RenRL r1 (Record t1) ici1,
-      RenRL r1 (Record t11) sc1,
-      HRLabelSet (HCons (LVPair l t5) t21),
-      RenLR l' ico (Record t6),
-      RenRL
-        l' (Record (HCons (LVPair l (Record HNil)) t2)) ici,
-      RenRL
-        l' (Record (HCons (LVPair l t5) t21)) sc,
-      HExtend (LVPair l l) l1 l',
-      HLeftUnion t4 (Record t23) (Record r2),
-      H2ProjectByLabels (HCons l HNil) t6 t13 t23,
-      HRearrange ls r2 r',
-      HLabelSet ls) =>
-     Rule lf hof sc ip li hoi ici spi li1 hoi1 ico t12
-     -> l1
-     -> l
-     -> Rule lf hof sc1 ip1 li1 hoi1 ici1 (Record HNil) t22 t3 ico1 t5
-     -> r1
-     -> Fam lf hof (Record t) ip
-     -> Fam li hoi (Record r) spi
-     -> Fam t22 t3 (Record r') t12
+graft ::                (HExtend (LVPair e e) l s,
+                         HasField e t2 ip1,
+                         RecordLabels t ls2,
+                         HRLabelSet a1,
+                         HRLabelSet (HCons (LVPair e (Record HNil)) a2),
+                         HRLabelSet (HCons (LVPair e v) a3),
+                         HRLabelSet a3,
+                         HRLabelSet a2,
+                         HRLabelSet a,
+                         MapLR s1 ico1 r1,
+                         MapLR s ico (Record t2),
+                         MapRL s (Record (HCons (LVPair e v) a3)) sc,
+                         MapRL s1 (Record a1) sc1,
+                         MapRL s1 (Record a) ici1,
+                         MapRL s (Record (HCons (LVPair e (Record HNil)) a2)) ici,
+                         H2ProjectByLabels ls t1 a1 b1,
+                         H2ProjectByLabels ls1 t1 a3 b3,
+                         H2ProjectByLabels (HCons e HNil) t2 t3 t4,
+                         H2ProjectByLabels ls1 t a2 b2,
+                         H2ProjectByLabels ls t a b,
+                         HRearrange ls2 r r',
+                         RecordValues l ls1,
+                         RecordValues s1 ls,
+                         HLeftUnion r1 (Record t4) (Record r),
+                         HLabelSet ls2) =>
+                        Rule lf hof sc ip li hoi ici spi li1 hoi1 ico p
+                        -> l
+                        -> e
+                        -> Rule lf hof sc1 ip1 li1 hoi1 ici1 (Record HNil) l1 ho ico1 v
+                        -> s1
+                        -> Fam lf hof (Record t1) ip
+                        -> Fam li hoi (Record t) spi
+                        -> Fam l1 ho (Record r') p
+
 graft rule1 chs1 lch rule2 chs2  (Fam lf hof sc ip) (Fam l ho ici spi)  =
                let  spi1 = spi
                     spi2 = emptyRecord
-                    ls2 = recordValues (Record chs2)
-                    (ici2,ici1') = hProjectByLabels2 ls2 ici
-                    ici1 = lch .=. emptyRecord .*. ici1' 
-                    (sc2,sc1')   = hProjectByLabels2 ls2 sc
-                    sc1 = lch .=. spo2 .*. sc1'
+
+                    -- ls1' and ls2 don't need to be disjoint
+                    ls1'   = recordValues (Record chs1)
+                    ls2    = recordValues (Record chs2)
+                    ici1'  = hProjectByLabels ls1' ici
+                    ici2   = hProjectByLabels ls2  ici
+                    ici1   = lch .=. emptyRecord .*. ici1' 
+                    sc1'   = hProjectByLabels ls1' sc
+                    sc2    = hProjectByLabels ls2  sc
+                    sc1    = lch .=. spo2 .*. sc1'
+
                     ip1 = ip
                     ip2 = ico1 # lch
 
-                    (Fam l1 ho1 ico1 spo1) = (rename rule1 (lch .=. lch .*. chs1))  (Fam lf hof sc1 ip1) (Fam l  ho  ici1 spi1) 
-                    (Fam l2 ho2 ico2 spo2) = (rename rule2 chs2)                    (Fam lf hof sc2 ip2) (Fam l1 ho1 ici2 spi2)
+                    (Fam l1 ho1 ico1 spo1) = (mapChildren rule1 (lch .=. lch .*. chs1))  (Fam lf hof sc1 ip1) (Fam l  ho  ici1 spi1) 
+                    (Fam l2 ho2 ico2 spo2) = (mapChildren rule2 chs2)                    (Fam lf hof sc2 ip2) (Fam l1 ho1 ici2 spi2)
+
                     ls = recordLabels ici 
                     ico = hRearrange ls $ hLeftUnion ico2 (hDeleteAtLabel lch ico1)
                     spo = spo1
                in   (Fam l2 ho2 ico spo)
 
 
+-- | A generalized version of 'graft' that grafts into or maps every children.
+macro ::                (RecordLabels r ls, HRearrange ls r1 r', HLabelSet ls) =>
+                        (Fam l1 ho1 c p1 -> Fam l ho c1 p -> Fam t t1 t2 p2)
+                        -> ((l1, ho1, c2, Record r)
+                            -> (t, t1, t2, Record HNil, Record HNil)
+                            -> (l2, ho2, Record r1, c1, c))
+                        -> Fam l1 ho1 c2 p1
+                        -> Fam l ho (Record r) p
+                        -> Fam l2 ho2 (Record r') p2
+ 
+macro rule1 chRules (Fam lf hof sc ip) (Fam l ho ici spi)  =
+               let  spi1 = spi
+                    ip1  = ip
 
+                    (Fam l1 ho1 ico1 spo1) = rule1  (Fam lf hof sc1 ip1) (Fam l  ho  ici1 spi1) 
+                    (l2, ho2, ico, ici1, sc1) = chRules (lf, hof, sc, ici) (l1, ho1, ico1, emptyRecord, emptyRecord) 
+
+                    ls = recordLabels ici 
+                    ico' = hRearrange ls ico
+                    spo = spo1
+               in   (Fam l2 ho2 ico' spo)
+
+-- | Child mapping definition, it reads /replaced by/. 
+(==>) ::                (HExtend (LVPair l2 v) l1 t10,
+                          HExtend (LVPair l2 (Record HNil)) l t9,
+                          HasField l2 t3 ip,
+                          HRLabelSet a1,
+                          HRLabelSet a,
+                          MapLR s ico r,
+                          MapRL s (Record a) ici,
+                          MapRL s (Record a1) sc,
+                          H2ProjectByLabels ls t2 a1 b1,
+                          H2ProjectByLabels (HCons l2 HNil) t3 t4 t5,
+                          H2ProjectByLabels ls t1 a b,
+                          RecordValues s ls,
+                          HLeftUnion r (Record t5) t8) =>
+                         l2
+                         -> (Rule lf hof sc ip li hoi ici (Record HNil) t6 t7 ico v, s)
+                         -> (lf, hof, (Record t2), Record t1)
+                         -> (li, hoi, Record t3, l, l1)
+                         -> (t6, t7, t8, t9, t10)
+
+lch ==> (rule2, chMap) = \(lf, hof, sc, ici) (l1,ho1,ico1,ici1,sc1)  ->
+               let  spi2 = emptyRecord
+
+                    ls2    = recordValues (Record chMap)
+                    ici2   = hProjectByLabels ls2  ici
+
+                    sc2    = hProjectByLabels ls2  sc
+
+                    ip2 = ico1 # lch
+
+                    (Fam l2 ho2 ico2 spo2) = (mapChildren rule2 chMap)  (Fam lf hof sc2 ip2) (Fam l1 ho1 ici2 spi2)
+
+                    ico1' = hLeftUnion ico2 (hDeleteAtLabel lch ico1)
+                    ici1' = lch .=. emptyRecord .*. ici1
+                    sc1'  = lch .=. spo2 .*. sc1
+               in   (l2, ho2, ico1', ici1', sc1')
+
+
+-- | Child mapping definition, it reads /binds to/.
+(-->) ::                (HExtend (LVPair e v1) l1 t10,
+                         HExtend (LVPair e v) l t11,
+                         HasField (Proxy lch2) r1 v1,
+                         HasField e t4 v2,
+                         HasField (Proxy lch2) r v,
+                         HRLabelSet (HCons (LVPair (Proxy lch2) v2) t3),
+                         H2ProjectByLabels (HCons (Proxy lch2) HNil) t6 t7 t4,
+                         H2ProjectByLabels (HCons e HNil) t4 t5 t3) =>
+                        e
+                        -> (Proxy lch2)
+                        -> (t, t1, r, r1)
+                        -> (t8, t9, Record t6, l1, l)
+                        -> (t8, t9, Record (HCons (LVPair (Proxy lch2) v2) t3), t10, t11)
+lch --> lch2 = \(_, _, sc, ici) (l1,ho1,ico1,ici1,sc1)  ->
+               let  ico1' = hRenameLabel lch lch2 (hDeleteAtLabel lch2 ico1)
+                    ici1' = lch .=. (ici # lch2) .*. ici1
+                    sc1'  = lch .=. (sc # lch2) .*. sc1
+               in   (l1, ho1, ico1', ici1',  sc1')
+
+-- | Composition of children mapping definitions for the function 'macro'.
+(<.>)  ::  ((lf,hof,sc,ici) -> (l2,ho2,ico1',ici1',sc1') -> (l3,ho3,ico1'',ici1'',sc1'')) 
+       ->  ((lf,hof,sc,ici) -> (l1,ho1,ico1,ici1,sc1) -> (l2,ho2,ico1',ici1',sc1')) 
+       ->  (lf,hof,sc,ici) -> (l1,ho1,ico1,ici1,sc1) -> (l3,ho3,ico1'',ici1'',sc1'')
+ch1 <.> ch2 = \inp -> (ch1 inp) . (ch2 inp)
+
+
+
 -- Monadic Interface 
 
 data Lhs
@@ -433,6 +618,7 @@        => At (Proxy (lch,nt)) m v where
   at lbl = liftM (\(Fam _ _ chi _) -> chi # lbl) ask
 
+
 instance MonadReader (Fam l ho chi par) m
        => At (Proxy Lhs) m par where
   at _ = liftM (\(Fam _ _ _ par) -> par) ask
@@ -531,11 +717,11 @@ --   semantic functions of the children, and builds a
 --   function from the inherited attributes of the parent to its
 --   synthesized attributes.
-knit  ::  (HLeftUnion ho fc fc', Kn fc' ic sc,  Empties fc' ec) 
+knit  ::  (HLeftUnion fc ho fc', Kn fc' ic sc,  Empties fc' ec) 
       =>  Rule l ho sc ip (Record HNil) (Record HNil) ec (Record HNil) l ho ic sp
           -> fc -> ip -> sp
 knit  rule fc ip =  
-  let  fc' = hLeftUnion ho fc 
+  let  fc' = hLeftUnion fc ho 
        ec = empties fc'
 
        (Fam l ho ic sp)   = rule  (Fam l            ho           sc  ip) 

@@ -1,16 +1,18 @@ {-# LANGUAGE TemplateHaskell, CPP #-} {-# OPTIONS -XEmptyDataDecls #-} -module Language.Grammars.AspectAG.Derive (deriveAG, attLabel, attLabels, chLabel, chLabels, typeList) where+module Language.Grammars.AspectAG.Derive (deriveAG, extendAG, addNT, addProd, attLabel, attLabels, chLabel, chLabels) where  import Language.Haskell.TH  import Data.Set (Set)-import Data.List (isPrefixOf)+import Data.List (isPrefixOf, isSuffixOf) import qualified Data.Set as S  import Language.Grammars.AspectAG +-- import Debug.Trace+ data UserType  = UserD Name [Name] [Con] type TypeDecls = (Set Name, [Dec]) @@ -41,7 +43,7 @@ chLabel n t = chLabels [n] t  chLabels ::  [String] -> Name -> Q [Dec]-chLabels ns t = (liftM concat) $ mapM (label t . mkName) ns+chLabels ns ty = (liftM concat) $ mapM (label ty . mkName) ns   where       label t n = declareLabel (chTName n) (chName n) (tyLabel (chTName n) t)        tyLabel n t = appT (appT (conT $ mkName "(,)") (conT n)) (conT t) @@ -67,11 +69,35 @@               return decl  +extendAG :: Name -> [Name] -> Q [Dec]+extendAG n used = do+              (_,decl) <- derive n (S.fromList(used),[]) --eval)+              return decl +addNT :: String -> Q [Dec]+addNT nt = declareLabel ntn (ntName ntn ) (conT $ ntn)+    where ntn = mkName nt +addProd :: String -> [ (String, Name) ] -> Q [Dec]+addProd prod children = do+                let pn = mkName prod+                p  <- declareLabel (prdTName pn) (prdName pn) (conT $ prdTName pn)+                ch <- (liftM concat . mapM (\(a,b) -> chLabel a b)) children++                conargs <- newNames children+                bodyP <- [| knit $(aspV) $(childsP (map (mkName . fst) children) conargs) |] +                let semFCons = FunD (semPName pn) +                                    [(Clause (aspP:(map VarP conargs)) (NormalB bodyP) [])]+++                return (semFCons:p++ch)+ semName ::  Name -> Name semName t = mkName ("sem_"++(nameBase t)) +semPName ::  Name -> Name+semPName t = mkName ("semP_"++(nameBase t))+ derive :: Name -> TypeDecls -> Q TypeDecls  derive n (stn,decl) =      do@@ -92,38 +118,65 @@       let (cht,chn,cn) = getCtx c       (stn',decl') <- foldM (\td t -> deriveList (typeNames t) td) (stn,decl) cht       conargs <- newNames cht-      body <- [| knit ($(aspV) # $(att cn)) $(childs cht chn conargs) |] +      body <- [| knit ($(aspV) # $(attVar cn)) $(childs cht chn conargs) |]+      bodyP <- [| knit $(aspV) $(childsP chn conargs) |]        let semF = Clause (pat cn conargs) (NormalB body) []+      let semFCons = FunD (semPName cn) +                          [(Clause (aspP:(map VarP conargs)) (NormalB bodyP) [])]        lp <- declareLabel (prdTName cn) (prdName cn) (conT $ prdTName cn)       lc <- chLabels2 chn cht-      return ((stn',lp++lc++decl'),semF:fc)-  where-     newNames []     = return []-     newNames (_:as) = do-                        na  <- newName "x"-                        nas <- newNames as-                        return (na:nas)-     pat cn args = [aspP, ConP cn (map VarP args)] -     aspP = VarP $ mkName "asp"-     aspV = varE $ mkName "asp"-     att cn  = varE $ prdName cn-     ch  cn  = varE $ chName cn-     childs []     _      _      = [| emptyRecord |]-     childs (t:ts) (n:ns) (p:ps) = case (typeName1 t) of-                                     Just tn -> [| $(ch n) .=. $(chFun tn p)  .*. $(childs ts ns ps) |]-                                     Nothing -> [| $(childs ts ns ps) |]-     childs _      _      _      = error "Impossible case!!"-     deriveList ns td = foldM (flip $ derive) td ns-     chFun tn n =  -              do-                  i <- reify (tn)-                  if isNT i-                   then [| $(varE (semName tn)) $(aspV) $(varE n) |]-                   else [| ( \(Record HNil) -> $(varE n) ) |]-           +      return ((stn',semFCons:(lp++lc++decl')),semF:fc)  +newNames ::  [t] -> Q [Name]+newNames []     = return []+newNames (_:as) = do+                   na  <- newName "x"+                   nas <- newNames as+                   return (na:nas) +pat ::  Name -> [Name] -> [Pat]+pat cn args | isSuffixOf ("_Cons") (nameBase cn) = [aspP, InfixP (VarP $ args !! 0) (mkName ":") (VarP $ args !! 1) ]+            | isSuffixOf ("_Nil")  (nameBase cn) = [aspP, ListP [] ]+            | isSuffixOf ("_Just") (nameBase cn) = [aspP, ConP (mkName "Just") (map VarP args) ]+            | isSuffixOf ("_Nothing")  (nameBase cn) = [aspP, ConP (mkName "Nothing") [] ]+            | otherwise =  [aspP, ConP cn (map VarP args)] ++aspP ::  Pat+aspP = VarP $ mkName "asp"+aspV ::  ExpQ+aspV = varE $ mkName "asp"+attVar ::  Name -> ExpQ+attVar cn  = varE $ prdName cn+chVar ::  Name -> ExpQ+chVar  cn  = varE $ chName cn++childs ::  [Type] -> [Name] -> [Name] -> Q Exp+childs []     _      _      = [| emptyRecord |]+childs (t:ts) (n:ns) (p:ps) = case (typeName1 t) of+                                Just tn -> [| $(chVar n) .=. $(chFun tn p)  .*. $(childs ts ns ps) |]+                                Nothing -> [| $(childs ts ns ps) |]+childs _      _      _      = error "Impossible case!!"++childsP ::  [Name] -> [Name] -> Q Exp+childsP []     _      = [| emptyRecord |]+childsP (n:ns) (p:ps) = [| $(chVar n) .=. $(varE p)  .*. $(childsP ns ps) |]+childsP _      _      = error "Impossible case!!"++deriveList ::  [Name] -> TypeDecls -> Q TypeDecls+deriveList ns td = foldM (flip $ derive) td ns++chFun ::  Name -> Name -> Q Exp+chFun tn n =  +         do+             i <- reify (tn)+             if isNT i+              then [| $(varE (semName tn)) $(aspV) $(varE n) |]+              else [| ( \(Record HNil) -> $(varE n) ) |]+      +++ #if __GLASGOW_HASKELL__ < 612  getUserType :: Info -> Q UserType getUserType info = do@@ -143,6 +196,20 @@         TyConI d -> case d of             (DataD     _ uname args cs  _)  -> return $ UserD uname (map f args) cs              (NewtypeD  _ uname args c   _)  -> return $ UserD uname (map f args) [c]+            (TySynD    uname args t)        -> let  name = nameBase uname+                                                    cs = case t of+                                                                (AppT ListT lt) -> [ NormalC (mkName $ name ++ "_Nil") []+                                                                                   , RecC (mkName $ name ++ "_Cons") +                                                                                          [ (mkName ("hd_" ++ name ++ "_Cons"),NotStrict,lt) +                                                                                          , (mkName ("tl_" ++ name ++ "_Cons"),NotStrict,ConT uname) ]]+                                                                (AppT (ConT nt) pt) ->+                                                                            case (nameBase nt) of+                                                                                "Maybe" ->   [ NormalC (mkName $ name ++ "_Nothing") []+                                                                                             , RecC (mkName $ name ++ "_Just") +                                                                                                    [ (mkName ("just_" ++ name ++ "_Just"),NotStrict,pt) ]]+                                                                                _ -> error "Not allowed type synonym"+                                                                _ -> error "Not allowed type synonym"+                                               in   return (UserD uname (map f args) cs)             _                               -> scopeError         _ -> scopeError     where scopeError = error $ "Can only be used on algebraic datatypes"@@ -167,8 +234,9 @@  isNT ::  Info -> Bool isNT (PrimTyConI _ _ _)          =  False-isNT (TyConI (DataD _ n _ _ _))  =  not $ isPrefixOf "GHC" (show n) -- GHC types can't be non-terminals-isNT (TyConI (TySynD _ _ _))     =  False   -- type synonyms to escape+isNT (TyConI (DataD _ n _ _ _))  =  not $ isPrefixOf "GHC" (show n)         -- GHC types can't be non-terminals+isNT (TyConI (TySynD n _ _))     =  (not $ isPrefixOf "GHC" (show n)) &&    -- GHC types can't be non-terminals+                                    (not $ isPrefixOf "GHC" (nameBase n))   -- type synonyms starting with GHC to escape (example: GHC_MyType) isNT  _                          =  True  @@ -188,22 +256,6 @@     AppT t1 _                -> typeName1 t1     ListT                    -> Nothing     _                        -> error $ "Not valid type " ++ (show t)----typeList :: String -> String -> Q [Dec]-typeList nData nArg =  -   do-     let ddef = DataD [] dataName [] [ RecC consName [(hdName, NotStrict, ConT argName), (tlName ,NotStrict, ConT dataName) ]-                                     , NormalC nilName []] []-     return [ ddef ]- where-  dataName = mkName nData-  argName  = mkName nArg-  consName = mkName $ "Cons" ++ nData-  nilName  = mkName $ "Nil"  ++ nData-  hdName   = mkName $ "hd"   ++ nData-  tlName   = mkName $ "tl"   ++ nData