...
 
Commits (2)
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeInType #-}
module Rose where
import Language.Grammars.AspectAG
import Language.Grammars.AspectAG.TH
import Data.Type.Require
import Data.Kind
import Data.Proxy
--- data Rose = Node Int ListRose
--- data ListRose = Nil | Cons Rose ListRose
$(addNont "Rose")
$(addNont "List")
$(addProd "Node" ''Nt_Rose [("v", Ter ''Int),
("ls", NonTer ''Nt_List)])
$(addProd "Nil" ''Nt_List [])
$(addProd "Cons" ''Nt_List [("hd", NonTer ''Nt_Rose),
("tl", NonTer ''Nt_List)])
$(closeNTs [''Nt_List, ''Nt_Rose])
$(mkSemFuncs [''Nt_List, ''Nt_Rose])
exampleT =
Node 5 (Cons (Node 3 Nil)
(Cons (Node 3 (Cons (Node 3 Nil) Nil))
Nil))
-- size of Tree
$(attLabels [("size", ''Int)])
-- TODO: solve this bug
-- asp_size =
-- use size p_Node (nt_List .:. eL) ((+) . (+1)) 1 .+:
-- syn size p_Nil (pure 0) .+:
-- use size p_Cons (nt_Rose .:. nt_List .:. eL) (+) 1 .+:
-- emptyAspect
asp_size =
syn size p_Node ((1+) <$> at ch_ls size) .+:
syn size p_Nil (pure 0) .+:
syn size p_Cons ((+) <$> at ch_hd size <*> at ch_tl size) .+:
emptyAspectC (p_Node .:. p_Cons .:. p_Nil .:. eL) Proxy
siz t = sem_Rose asp_size t emptyAtt #. size
-- a constant attribute, to be defined only in one nonterminal
$(attLabels [("cst", ''String)])
asp_const =
syn cst p_Node (at ch_ls cst -- pure "cst"
) .+:
emptyAspectC (p_Node .:. p_Cons .:. p_Nil .:. eL) Proxy
-- same:
-- emptyRuleatPrd p_Node .+:
-- emptyRuleatPrd p_Cons .+:
-- emptyRuleatPrd p_Nil .+:
-- emptyAspect
con t = sem_Rose asp_const t emptyAtt #. cst
type family ProdsOfNt1 (nt :: NT) :: [Prod]
type instance ProdsOfNt1 Nt_Rose = '[P_Node]
type family ProdsOfNtRec (nt :: NT) :: [Prod]
type instance ProdsOfNtRec Nt_Rose = '[P_Node, P_Nil, P_Cons]
-- -- | generada con TH
-- type family NtsOfProd (prd :: Prod) :: [NT]
-- emptyAspectC
......@@ -48,7 +48,7 @@ module Language.Grammars.AspectAG
inhmod, inhmodM,
emptyRule,
emptyRuleatPrd,
emptyRuleAtPrd,
ext,
-- * Aspects
......@@ -73,9 +73,8 @@ module Language.Grammars.AspectAG
knitAspect,
traceAspect,
traceRule,
copyatChi,
copyAtChi,
use,
PrdList(..),
emptyAspectC,
module Data.GenRec,
module Language.Grammars.AspectAG.HList
......@@ -151,8 +150,8 @@ newtype CRule (ctx :: [ErrorMessage]) prd sc ip ic sp ic' sp'
emptyRule =
CRule $ \Proxy -> \fam inp -> inp
emptyRuleatPrd :: Label prd -> CRule ctx prd sc ip ic' sp' ic' sp'
emptyRuleatPrd Label = emptyRule
emptyRuleAtPrd :: Label prd -> CRule ctx prd sc ip ic' sp' ic' sp'
emptyRuleAtPrd Label = emptyRule
-- | Aspects, tagged with context. 'Aspect' is a record instance having
-- productions as labels, containing 'Rule's as fields.
......@@ -820,19 +819,6 @@ type UseC att prd nts t' sp sc sp' ctx =
~ Rec AttReco sp'
)
-- | a rule to copy one attribute `att` from the parent to the children `chi`
copyatChi att chi
= inh att (prdFromChi chi) chi (at lhs att)
-- data ChiList (chs :: [Child]) :: Type where
-- NilCh :: ChiList '[]
-- ConsCh :: Label ch -> ChiList chs -> ChiList (ch ': chs)
-- data PrdList (chs :: [Prod]) :: Type where
-- NilPrd :: PrdList '[]
-- ConsPrd :: Label pr -> PrdList prs -> PrdList (pr ': prs)
class EmptyAspectSameShape (es1 :: [k]) (es2 :: [m])
instance (es2 ~ '[]) => EmptyAspectSameShape '[] es2
......@@ -840,6 +826,7 @@ instance (EmptyAspectSameShape xs ys, es2 ~ ( '(y1,y2,y3,y4) ': ys))
=> EmptyAspectSameShape (x ': xs) es2
-- require KLIST de prods?, NO, eso está en el kind!
class
EmptyAspectSameShape prds polyArgs
=>
......@@ -847,31 +834,67 @@ class
(polyArgs :: [([(Child, [(Att, Type)])], [(Att, Type)],
[(Child, [(Att, Type)])], [(Att, Type)] )])
ctx where
type EmptyAspectR prds polyArgs :: [(Prod, Type)]
emptyAspectC :: PrdList prds -> Proxy polyArgs
-> CAspect ctx (EmptyAspectR prds polyArgs)
type EmptyAspectR prds polyArgs ctx :: [(Prod, Type)]
emptyAspectC :: KList prds -> Proxy polyArgs
-> CAspect ctx (EmptyAspectR prds polyArgs ctx)
instance
EmptyAspect '[] '[] ctx where
type EmptyAspectR '[] '[] = '[]
emptyAspectC _ _ = emptyAspect
type EmptyAspectR '[] '[] ctx = '[]
emptyAspectC _ _ = emptyAspect
instance
( EmptyAspect prds polys '[]
, ReqR (OpComRA '[] prd ((CRule '[] prd sc ip ic' sp' ic' sp'))
(EmptyAspectR prds polys)) ~ Rec PrdReco asp
, ExtAspect '[] prd sc ip ic' sp' ic' sp'
(EmptyAspectR prds polys) (EmptyAspectR (prd ': prds) ( '(sc, ip, ic', sp') ': polys))
( EmptyAspect prds polys ctx
, ExtAspect ctx prd sc ip ic sp ic sp
(EmptyAspectR prds polys ctx)
(EmptyAspectR (prd ': prds) ( '(sc, ip, ic, sp) ': polys) ctx)
)
=>
EmptyAspect (prd ': prds) ( '(sc, ip, ic', sp') ': polys) '[] where
type EmptyAspectR (prd ': prds) ( '(sc, ip, ic', sp') ': polys) =
UnWrap (ReqR (OpComRA '[] prd ((CRule '[] prd sc ip ic' sp' ic' sp'))
(EmptyAspectR prds polys)))
emptyAspectC (ConsPrd prd prds) (p :: Proxy ( '(sc, ip, ic', sp') ': polys)) =
(emptyRule :: CRule '[] prd sc ip ic' sp' ic' sp')
EmptyAspect (prd ': prds) ( '(sc, ip, ic, sp) ': polys) ctx where
type EmptyAspectR (prd ': prds) ( '(sc, ip, ic, sp) ': polys) ctx =
UnWrap (ReqR (OpComRA '[] prd ((CRule '[] prd sc ip ic sp ic sp))
(EmptyAspectR prds polys ctx)))
emptyAspectC (KCons prd prds) (p :: Proxy ( '(sc, ip, ic, sp) ': polys)) =
(emptyRule :: CRule ctx prd sc ip ic sp ic sp)
.+: emptyAspectC @prds @polys prds (Proxy @ polys)
data PrdList (l :: [Prod]) :: Type where
EP :: PrdList '[]
ConsPrd :: Label prd -> PrdList prds -> PrdList (prd ': prds)
emptyAspectForProds prdList = emptyAspectC prdList Proxy
-- ** copy rules
-- | a rule to copy one attribute `att` from the parent to the children `chi`
copyAtChi att chi
= inh att (prdFromChi chi) chi (at lhs att)
-- | to copy at many children
class CopyAtChiList (att :: Att)
(chi :: [Child])
(polyArgs :: [([(Child, [(Att, Type)])], [(Att, Type)],
[(Child, [(Att, Type)])], [(Att, Type)],
[(Child, [(Att, Type)])], [(Att, Type)] )])
ctx where
type CopyAtChiListR att chi polyArgs ctx :: [(Prod, Type)]
copyAtChiList :: Label att -> KList chi -> Proxy polyArgs
-> CAspect ctx (CopyAtChiListR att chi polyArgs ctx)
instance CopyAtChiList att '[] '[] ctx where
type CopyAtChiListR att '[] '[] ctx = '[]
copyAtChiList _ _ _ = emptyAspect
-- instance
-- ( CopyAtChiList ('Att att t) chi polys ctx
-- , prd ~ Prd p nt
-- , tnt ~ Left nc
-- )
-- =>
-- CopyAtChiList ('Att att t) (Chi ch prd tnt ': chi)
-- ('(sc, ip, ic, sp, ic', sp') ': polys) ctx where
-- type CopyAtChiListR ('Att att t) (Chi ch prd tnt ': chi)
-- ('(sc, ip, ic, sp, ic', sp') ': polys) ctx =
-- UnWrap (ReqR (OpComRA '[] prd ((CRule '[] prd sc ip ic sp ic' sp'))
-- (CopyAtChiListR ('Att att t) chi polys ctx)))
-- copyAtChiList att (KCons chi chs :: KList ('Chi ch prd tnt ': chs) )
-- (p :: Proxy ( '(sc, ip, ic, sp, ic', sp') ': polys))
-- = copyAtChi att chi
-- .+: copyAtChiList @('Att att t) @chs att chs (Proxy @polys)