diff --git a/AspectAG.cabal b/AspectAG.cabal --- a/AspectAG.cabal +++ b/AspectAG.cabal @@ -1,5 +1,5 @@ name: AspectAG -version: 0.3.2 +version: 0.3.3 cabal-version: >= 1.2.3 license: LGPL license-file: COPYRIGHT diff --git a/examples/Main.hs b/examples/Main.hs deleted file mode 100644 --- a/examples/Main.hs +++ /dev/null @@ -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 - diff --git a/examples/testList.hs b/examples/testList.hs --- a/examples/testList.hs +++ b/examples/testList.hs @@ -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 diff --git a/src/Language/Grammars/AspectAG.hs b/src/Language/Grammars/AspectAG.hs --- a/src/Language/Grammars/AspectAG.hs +++ b/src/Language/Grammars/AspectAG.hs @@ -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) diff --git a/src/Language/Grammars/AspectAG/Derive.hs b/src/Language/Grammars/AspectAG/Derive.hs --- a/src/Language/Grammars/AspectAG/Derive.hs +++ b/src/Language/Grammars/AspectAG/Derive.hs @@ -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