{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# LANGUAGE DataKinds,
TypeOperators,
PolyKinds,
GADTs,
TypeInType,
RankNTypes,
StandaloneDeriving,
FlexibleInstances,
FlexibleContexts,
ConstraintKinds,
MultiParamTypeClasses,
FunctionalDependencies,
UndecidableInstances,
ScopedTypeVariables,
TypeFamilies,
InstanceSigs,
AllowAmbiguousTypes,
TypeApplications,
PatternSynonyms,
PartialTypeSignatures
#-}
module Language.Grammars.AspectAG.RecordInstances where
import Data.Type.Require
import Data.GenRec
import GHC.TypeLits
import Data.Kind
import Data.Proxy
data Att = Att Symbol Type
data Prod = Prd Symbol NT
data Child = Chi Symbol Prod (Either NT T)
data NT = NT Symbol
data T = T Type
prdFromChi :: Label (Chi nam prd tnt) -> Label prd
prdFromChi _ = Label
type instance Cmp ('Att a _) ('Att b _) =
CmpSymbol a b
type instance Cmp ('Prd a _) ('Prd b _) =
CmpSymbol a b
type instance Cmp ('Chi a _ _) ('Chi b _ _) =
CmpSymbol a b
type instance ShowTE ('Att l t) = Text "Attribute " :<>: Text l
:<>: Text ":"
:<>: ShowTE t
type instance ShowTE ('Prd l nt) = ShowTE nt :<>: Text "::Production "
:<>: Text l
type instance ShowTE ('Chi l p s) = ShowTE p :<>: Text "::Child " :<>: Text l
:<>: Text ":" :<>: ShowTE s
type instance ShowTE ('Left l) = ShowTE l
type instance ShowTE ('Right r) = ShowTE r
type instance ShowTE ('NT l) = Text "Non-Terminal " :<>: Text l
type instance ShowTE ('T l) = Text "Terminal " :<>: ShowTE l
type Record = Rec Reco
data Reco
type instance WrapField Reco (v :: Type) = v
type instance ShowRec Reco = "Record"
type instance ShowField Reco = "field named "
type Tagged = TagField Reco
pattern Tagged :: v -> Tagged l v
pattern Tagged v = TagField Label Label v
type Attribution (attr :: [(Att,Type)]) = Rec AttReco attr
data AttReco
type instance WrapField AttReco (v :: Type) = v
type instance ShowRec AttReco = "Attribution"
type instance ShowField AttReco = "attribute named "
type Attribute (l :: Att) (v :: Type) = TagField AttReco l v
pattern Attribute :: v -> TagField AttReco l v
pattern Attribute v = TagField Label Label v
infixr 4 =.
(=.) :: Label l -> v -> Attribute l v
Label =. v = Attribute v
infixr 2 *.
(l :: Attribute att val) *. (r :: Attribution atts) = l .*. r
emptyAtt :: Attribution '[]
emptyAtt = EmptyRec
infixl 7 #.
(#.) ::
( msg ~ '[Text "looking up attribute " :<>: ShowTE l :$$:
Text "on " :<>: ShowTE r
]
, Require (OpLookup AttReco l r) msg
)
=> Attribution r -> Label l -> ReqR (OpLookup AttReco l r)
(attr :: Attribution r) #. (l :: Label l)
= let prctx = Proxy @ '[Text "looking up attribute " :<>: ShowTE l :$$:
Text "on " :<>: ShowTE r
]
in req prctx (OpLookup @_ @(AttReco) l attr)
type ChAttsRec prd (chs :: [(Child,[(Att,Type)])])
= Rec (ChiReco prd) chs
data ChiReco (prd :: Prod)
type instance WrapField (ChiReco prd) v
= Attribution v
type instance ShowRec (ChiReco a) = "Children Map"
type instance ShowField (ChiReco a) = "child labelled "
type TaggedChAttr prd = TagField (ChiReco prd)
pattern TaggedChAttr :: Label l -> WrapField (ChiReco prd) v
-> TaggedChAttr prd l v
pattern TaggedChAttr l v
= TagField (Label :: Label (ChiReco prd)) l v
infixr 4 .=
(.=) :: Label l -> WrapField (ChiReco prd) v -> TaggedChAttr prd l v
(.=) = TaggedChAttr
infixr 2 .*
(tch :: TaggedChAttr prd ch attrib) .* (chs :: ChAttsRec prd attribs) = tch .*. chs
emptyCh :: ChAttsRec prd '[]
emptyCh = EmptyRec
unTaggedChAttr :: TaggedChAttr prd l v -> WrapField (ChiReco prd) v
unTaggedChAttr (TaggedChAttr _ a) = a
labelChAttr :: TaggedChAttr prd l a -> Label l
labelChAttr _ = Label
infixl 8 .#
(.#) ::
( c ~ ('Chi ch prd nt)
, ctx ~ '[Text "looking up " :<>: ShowTE c :$$:
Text "on " :<>: ShowTE r :$$:
Text "producion: " :<>: ShowTE prd
]
, Require (OpLookup (ChiReco prd) c r) ctx
) =>
Rec (ChiReco prd) r -> Label c -> ReqR (OpLookup (ChiReco prd) c r)
(chi :: Rec (ChiReco prd) r) .# (l :: Label c)
= let prctx = Proxy @ '[Text "looking up " :<>: ShowTE c :$$:
Text "on " :<>: ShowTE r :$$:
Text "producion: " :<>: ShowTE prd
]
in req prctx (OpLookup @_ @(ChiReco prd) l chi)
data PrdReco
type instance WrapField PrdReco (rule :: Type)
= rule
type Aspect (asp :: [(Prod, Type)]) = Rec PrdReco asp
type instance ShowRec PrdReco = "Aspect"
type instance ShowField PrdReco = "production named "