...
 
Commits (8)
......@@ -10,7 +10,7 @@ name: AspectAG
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
version: 0.5.1.0
version: 0.5.2.0
-- A short (one-line) description of the package.
synopsis: Strongly typed Attribute Grammars implemented using type-level programming.
......@@ -66,12 +66,18 @@ cabal-version: >=1.10
library
-- Modules exported by the library.
exposed-modules: Language.Grammars.AspectAG,
Language.Grammars.FastAG,
Language.Grammars.AspectAG.TH,
Language.Grammars.AspectAG.HList,
Language.Grammars.AspectAG.TPrelude,
Language.Grammars.AspectAG.GenRecord,
Language.Grammars.AspectAG.RecordInstances,
Language.Grammars.AspectAG.Require
Language.Grammars.AspectAG.Require,
Language.Grammars.FastAG.GenRecord,
Language.Grammars.FastAG.HList,
Language.Grammars.FastAG.RecordInstances,
Language.Grammars.FastAG.TPrelude,
Language.Grammars.FastAG.TH
-- LANGUAGE extensions used by modules in this package.
other-extensions: TypeInType,
TypeFamilies,
......
This diff is collapsed.
{-|
Module : Language.Grammars.AspectAG.GenRecord
Description : Record library, this will be eventually forked out
from AAG codebase and used as a standalone library, depending on it
Copyright : (c) Juan García Garland, Marcos Viera, 2019
License : GPL
Maintainer : jpgarcia@fing.edu.uy
Stability : experimental
Portability : POSIX
-}
{-# 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,
TypeFamilyDependencies
#-}
module Language.Grammars.FastAG.GenRecord where
import Prelude hiding (lookup)
import Data.Kind
--import Data.Type.Equality hiding ((==))
import Data.Proxy
import Language.Grammars.FastAG.TPrelude
import GHC.TypeLits
type family a == b where
a == b = Equal a b
-- * Pretty constructors
infixr 2 .*.
(.*.) :: (Extend c l v r, a ~ WrapField c v)
=> TagField c l v -> Rec c r -> Rec c (ExtendR c l v r)
((TagField (labelc :: Label c) (labell :: Label l) (v :: a)) :: TagField c l v ) .*. (r :: Rec c r)
= extend labell (Proxy @v) v r
tailRec :: Rec c ( '(l,v) ': r) -> Rec c r
tailRec (ConsRec _ t) = t
data Rec (c :: k) (r :: [(k', k'')]) :: Type where
EmptyRec :: Rec c '[]
ConsRec :: -- LabelSet ( '(l,v) ': r) =>
TagField c l v -> Rec c r -> Rec c ( '(l,v) ': r)
data TagField (cat :: k) (l :: k') (v :: k'') where
TagField :: Label c -> Label l -> WrapField c v -> TagField c l v
untagField :: TagField c l v -> WrapField c v
untagField (TagField lc lv v) = v
type family WrapField (c :: k') (v :: k) = ftype | ftype -> v
{-
Node: We cannot encode the dependency {ftype, c} -> v since
TypeFamilyDependencies does not support this general
dependencies. So from (WrapField c v) we can't infer c.
-}
type family UnWrap t :: k -- (t :: [(k,k')]) :: k'
type instance UnWrap (Rec c (r :: [(k, k')])) = r
----------------------------LOOKUP---------------------------------------------
class Lookup (c :: Type) (l :: k) (r :: [(k,k')]) where
type LookupR c l r :: Type
lookup :: Label l -> Rec c r -> LookupR c l r
class Lookup' (cmp :: Ordering) (c :: Type) (l :: k) (r :: [(k,k')]) where
type LookupR' cmp c l r :: Type
lookup' :: Label cmp -> Label l -> Rec c r -> LookupR' cmp c l r
instance
Lookup' (CMP l l') c l ( '(l', v) : r)
=> Lookup c l ( '(l', v) ': r) where
type LookupR c l ( '(l', v) ': r) = LookupR' (CMP l l') c l ( '(l', v) ': r)
lookup = lookup' (Label @ (CMP l l'))
instance
Lookup c l r
=> Lookup' 'GT c l ( '(l', v) : r) where
type LookupR' 'GT c l ( '(l', v) : r) = LookupR c l r
lookup' cmp l (ConsRec _ r) = lookup l r
instance
Lookup' 'EQ c l ( '(l, v) : r) where
type LookupR' 'EQ c l ( '(l, v) : r) = WrapField c v
lookup' cmp l (ConsRec lv r) = untagField lv
----------------------------UPDATE---------------------------------------------
class Update (c :: Type) (l :: k) (v :: k') (r :: [(k, k')]) where
type UpdateR c l v r :: [(k, k')]
update :: Label l -> Proxy v -> WrapField c v -> Rec c r
-> Rec c (UpdateR c l v r)
class Update' (cmp :: Ordering)
(c :: Type) (l :: k) (v :: k') (r :: [(k, k')]) where
type UpdateR' cmp c l v r :: [(k, k')]
update' :: Proxy cmp -> Label l -> Proxy v -> WrapField c v -> Rec c r
-> Rec c (UpdateR' cmp c l v r)
instance Update' (CMP l l') c l v ( '(l' , v') ': r) =>
Update c l v ( '(l' , v') ': r) where
type UpdateR c l v ( '(l' , v') ': r)
= UpdateR' (CMP l l') c l v ( '(l' , v') ': r)
update l _ (f :: WrapField c v) r
= update' (Proxy @(CMP l l')) l (Proxy @v) f r
instance Update c l v r =>
Update' 'GT c l v ( '(l' , v') ': r) where
type UpdateR' 'GT c l v ( '(l' , v') ': r)
= '(l' , v') ': UpdateR c l v r
update' Proxy l Proxy f (ConsRec x xs)
= ConsRec x $ (update l (Proxy @v) f xs)
instance
Update' 'EQ c l v ( '(l , v') ': r) where
type UpdateR' 'EQ c l v ( '(l , v') ': r)
= '(l, v) ': r
update' _ l _ f (ConsRec x xs)
= ConsRec (TagField Label l f) xs
----------------------------EXTEND---------------------------------------------
class Extend (c :: Type) (l :: k) (v :: k') (r :: [(k, k')]) where
type ExtendR c l v r :: [(k, k')]
extend :: Label l -> Proxy v -> WrapField c v -> Rec c r
-> Rec c (ExtendR c l v r)
class Extend' (cmp :: Ordering )(c :: Type) (l :: k) (v :: k') (r :: [(k, k')])
where
type ExtendR' cmp c l v r :: [(k, k')]
extend' :: Proxy cmp -> Label l -> Proxy v -> WrapField c v -> Rec c r
-> Rec c (ExtendR c l v r)
instance
Extend c l v '[] where
type ExtendR c l v '[]
= '(l, v) ': '[]
extend l _ f EmptyRec
= ConsRec (TagField Label l f) EmptyRec
instance Extend' (CMP l l') c l v ( '(l', v') : r) =>
Extend c l v ( '(l', v') ': r) where
type ExtendR c l v ( '(l', v') ': r)
= ExtendR' (CMP l l') c l v ( '(l', v') ': r)
extend l _ (f :: WrapField c v) r
= extend' (Proxy @(CMP l l')) l (Proxy @v) f r
instance ( Extend c l v r
, Rec c (ExtendR c l v ('(l', v') : r))
~ Rec c ( '(l', v') : ExtendR c l v r)
) =>
Extend' 'GT c l v ( '(l', v') ': r) where
type ExtendR' 'GT c l v ( '(l', v') ': r)
= '(l', v') ': ExtendR c l v r
extend' cmp l _ f (ConsRec x xs)
= ConsRec x (extend l (Proxy @v) f xs)
instance Rec c (ExtendR c l v ('(l', v') : r))
~ Rec c ('(l, v) : '(l', v') : r) =>
Extend' 'LT c l v ( '(l', v') ': r) where
type ExtendR' 'LT c l v ( '(l', v') ': r)
= ( '(l, v) ': '(l', v') ': r)
extend' cmp l _ f r
= ConsRec (TagField Label l f) r
{-|
Module : Language.Grammars.AspectAG.HList
Description : Heterogeneous Lists for AAG, inspired on HList
Copyright : (c) Juan García Garland, 2018
License : LGPL
Maintainer : jpgarcia@fing.edu.uy
Stability : experimental
Portability : POSIX
Implementation of strongly typed heterogeneous lists.
-}
{-# LANGUAGE TypeInType,
GADTs,
KindSignatures,
TypeOperators,
TypeFamilies,
MultiParamTypeClasses,
FlexibleInstances,
FlexibleContexts,
StandaloneDeriving,
UndecidableInstances,
FunctionalDependencies,
ConstraintKinds,
ScopedTypeVariables
#-}
module Language.Grammars.FastAG.HList where
import Language.Grammars.FastAG.TPrelude
import Data.Proxy
import Data.Type.Equality
import Data.Kind
import GHC.Exts
-- |Heterogeneous lists are implemented as a GADT
data HList (l :: [Type]) :: Type where
HNil :: HList '[]
HCons :: x -> HList xs -> HList (x ': xs)
-- | HMember is a test membership function.
--Since we are in Haskell the value level function computes with the evidence
class HMember (t :: Type) (l :: [Type]) where
type HMemberRes t l :: Bool
hMember :: Label t -> HList l -> Proxy (HMemberRes t l)
instance HMember t '[] where
type HMemberRes t '[] = 'False
hMember _ _ = Proxy
instance HMember t (t' ': ts) where
type HMemberRes t (t' ': ts) = Or (t == t') (HMemberRes t ts)
hMember _ _ = Proxy
-- | HMember' is a test membership function.
-- But looking up in a list of Labels
class HMember' (t :: k) (l :: [k]) where
type HMemberRes' t l :: Bool
hMember' :: f t -> KList l -> Proxy (HMemberRes' t l)
instance HMember' t '[] where
type HMemberRes' t '[] = 'False
hMember' _ _ = Proxy
instance HMember' t (t' ': ts) where
type HMemberRes' t (t' ': ts) = Or (t == t') (HMemberRes' t ts)
hMember' _ _ = Proxy
-- | No other functionality is needed for AAG
infixr 2 .:
(.:) = HCons
ε = HNil
-- | a polykinded heteogeneous list
data KList (l :: [k]) :: Type where
KNil :: KList '[]
KCons :: Label h -> KList l -> KList (h ': l)
infixr 2 .:.
(.:.) = KCons
eL = KNil
{-# 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
#-}
module Language.Grammars.FastAG.RecordInstances where
-- import Language.Grammars.AspectAG.Require
import Language.Grammars.FastAG.GenRecord
import Language.Grammars.FastAG.TPrelude
import GHC.TypeLits
import Data.Kind
import Data.Proxy
import Prelude hiding (lookup)
data Att = Att Symbol Type -- deriving Eq
data Prod = Prd Symbol NT --deriving Eq
data Child = Chi Symbol Prod (Either NT T) --deriving Eq
data NT = NT Symbol --deriving Eq
data T = T Type -- deriving Eq
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 ShowT ('Att l t) = Text "Attribute " :<>: Text l
-- :<>: Text ":"
-- :<>: ShowT t
-- type instance ShowT ('Prd l nt) = ShowT nt :<>: Text "::Production "
-- :<>: Text l
-- type instance ShowT ('Chi l p s) = ShowT p :<>: Text "::Child " :<>: Text l
-- :<>: Text ":" :<>: ShowT s
-- type instance ShowT ('Left l) = ShowT l
-- type instance ShowT ('Right r) = ShowT r
-- type instance ShowT ('NT l) = Text "Non-Terminal " :<>: Text l
-- type instance ShowT ('T l) = Text "Terminal " :<>: ShowT l
-- | * Records
-- | datatype definition
type Record = Rec Reco
-- | index type
data Reco
-- | field type
type instance WrapField Reco (v :: Type) = v
-- -- | Type level show utilities
-- type instance ShowRec Reco = "Record"
-- type instance ShowField Reco = "field named "
-- | ** Pattern Synonyms
pattern EmptyR :: Rec Reco '[]
pattern EmptyR = EmptyRec :: Rec Reco '[]
pattern ConsR :: (LabelSet ( '(l,v ) ': xs))
=> Tagged l v -> Rec Reco xs -> Rec Reco ( '(l,v ) ': xs)
pattern ConsR lv r = ConsRec lv r
type Tagged = TagField Reco
pattern Tagged :: v -> Tagged l v
pattern Tagged v = TagField Label Label v
-- ** Constructors
-- | Pretty Constructor
infixr 4 .=.
(.=.) :: Label l -> v -> Tagged l v
l .=. v = Tagged v
-- | For the empty Record
emptyRecord :: Record '[]
emptyRecord = EmptyR
unTagged :: Tagged l v -> v
unTagged (TagField _ _ v) = v
-- * Destructors
-- | Get a label
label :: Tagged l v -> Label l
label _ = Label
-- | Same, mnemonically defined
labelTChAtt :: Tagged l v -> Label l
labelTChAtt _ = Label
-- | Show instance, used for debugging
instance Show (Record '[]) where
show _ = "{}"
instance (Show v, Show (Record xs), (LabelSet ('(l, v) : xs))) =>
Show (Record ( '(l,v) ': xs ) ) where
show (ConsR lv xs) = let tail = show xs
in "{" ++ show (unTagged lv)
++ "," ++ drop 1 tail
-- | * Attribution
-- | An attribution is a record constructed from attributes
-- | datatype implementation
type Attribution (attr :: [(Att,Type)]) = Rec AttReco attr
-- | index type
data AttReco
-- | field type
type instance WrapField AttReco (v :: Type) = v
-- -- | type level utilities
-- type instance ShowRec AttReco = "Attribution"
-- type instance ShowField AttReco = "attribute named "
-- | Pattern Synonyms
pattern EmptyAtt :: Attribution '[]
pattern EmptyAtt = EmptyRec
pattern ConsAtt :: LabelSet ( '(att, val) ': atts) =>
Attribute att val -> Attribution atts -> Attribution ( '(att,val) ': atts)
pattern ConsAtt att atts = ConsRec att atts
-- | Attribute
type Attribute (l :: Att) (v :: Type) = TagField AttReco l v
pattern Attribute :: v -> TagField AttReco l v
pattern Attribute v = TagField Label Label v
-- ** Constructors
-- | A pretty constructor for an attribute
infixr 4 =.
(=.) :: Label l -> v -> Attribute l v
Label =. v = Attribute v
-- | Extending
infixr 2 *.
(*.) :: (Extend AttReco att val atts) =>
Attribute att val -> Attribution atts
-> Attribution (ExtendR AttReco att val atts)
lv *. r = case lv of
TagField _ l v -> extend l Proxy v r
att1 :: Label ('Att "a" Bool)
att1 = Label
att2 :: Label ('Att "aa" Bool)
att2 = Label
att3 :: Label ('Att "ab" Bool)
att3 = Label
reco = (att3 =. False) *. (att2 =. True) *.(att1 =. True) *. emptyAtt
-- | Empty
emptyAtt :: Attribution '[]
emptyAtt = EmptyRec
-- ** Destructors
infixl 7 #.
(#.) :: Lookup AttReco l r =>
Attribution r -> Label l -> LookupR AttReco l r
(attr :: Attribution r) #. (l :: Label l)
= lookup l attr
-- * Children
-- | operations for the children
-- | datatype implementation
type ChAttsRec prd (chs :: [(Child,[(Att,Type)])])
= Rec (ChiReco prd) chs
-- | index type
data ChiReco (prd :: Prod)
-- | Field type
type instance WrapField (ChiReco prd) v
= Attribution v
-- -- | Type level Show utilities
-- type instance ShowRec (ChiReco a) = "Children Map"
-- type instance ShowField (ChiReco a) = "child labelled "
-- ** Pattern synonyms
-- |since now we implement ChAttsRec as a generic record, this allows us to
-- recover pattern matching
pattern EmptyCh :: ChAttsRec prd '[]
pattern EmptyCh = EmptyRec
pattern ConsCh :: (LabelSet ( '( 'Chi ch prd nt, v) ': xs)) =>
TaggedChAttr prd ( 'Chi ch prd nt) v -> ChAttsRec prd xs
-> ChAttsRec prd ( '( 'Chi ch prd nt,v) ': xs)
pattern ConsCh h t = ConsRec h t
-- | Attributions tagged by a child
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
-- ** Constructors
-- | Pretty constructor for tagging a child
infixr 4 .=
(.=) :: Label l -> WrapField (ChiReco prd) v -> TaggedChAttr prd l v
(.=) = TaggedChAttr
-- | Pretty constructors
infixr 2 .*
(.*) :: Extend (ChiReco prd) ch attrib attribs =>
TaggedChAttr prd ch attrib -> ChAttsRec prd attribs
-> ChAttsRec prd (ExtendR (ChiReco prd) ch attrib attribs)
tch .* r = case tch of
TaggedChAttr l (v :: Attribution attrib) -> extend l (Proxy @attrib) v r
-- | empty
emptyCh :: ChAttsRec prd '[]
emptyCh = EmptyRec
-- ** Destructors
unTaggedChAttr :: TaggedChAttr prd l v -> WrapField (ChiReco prd) v
unTaggedChAttr (TaggedChAttr _ a) = a
labelChAttr :: TaggedChAttr prd l a -> Label l
labelChAttr _ = Label
infixl 8 .#
(.#) :: Lookup (ChiReco prd) c r =>
Rec (ChiReco prd) r -> Label c -> LookupR (ChiReco prd) c r
(chi :: Rec (ChiReco prd) r) .# (l :: Label c)
= lookup l chi
-- * Productions
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 "
{-
-}
{-# 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
#-}
module Language.Grammars.AspectAG.Require where
import Data.Kind
import Data.Proxy
import GHC.TypeLits
import Language.Grammars.AspectAG.TPrelude
import Data.Type.Equality
class Require (op :: Type)
(ctx :: [ErrorMessage]) where
type ReqR op :: Type
req :: Proxy ctx -> op -> ReqR op
instance (TypeError (Text "Error: " :<>: m :$$:
Text "trace: " :<>: ShowCTX ctx))
=> Require (OpError m) ctx where {}
data OpError (m :: ErrorMessage) where {}
type family ShowCTX (ctx :: [ErrorMessage]) :: ErrorMessage where
ShowCTX '[] = Text ""
ShowCTX (m ': ms) = m :$$: ShowCTX ms
type family ShowEM (m :: ErrorMessage) :: ErrorMessage
type family ShowT (t :: k) :: ErrorMessage
type instance ShowT (t :: Type) = ShowType t
{-
Abro esta familia para poder definirla de manera extensible, porque no sabemos
en GenReord como se muestran los tipos para instancias concretas. El problema es
que estaba definida con un pattern que capturaba todos los demas casos al final
y en tf cerradas no se admite overlap. Entonces defino aca una instancia para el
kind t (era a fin de cuentas lo que caia en el último pattern)
-}
type RequireR (op :: Type ) (ctx:: [ErrorMessage]) (res :: Type)
= (Require op ctx, ReqR op ~ res)
type RequireEq (t1 :: k )(t2 :: k) (ctx:: [ErrorMessage])
= (Require (OpEq t1 t2) ctx, t1 ~ t2)
data OpEq t1 t2
instance RequireEqRes t1 t2 ctx
=> Require (OpEq t1 t2) ctx where
type ReqR (OpEq t1 t2) = ()
req = undefined
type family RequireEqRes (t1 :: k) (t2 :: k)
(ctx :: [ErrorMessage]) :: Constraint where
RequireEqRes t1 t2 ctx = If (t1 `Equal` t2) (() :: Constraint)
(Require (OpError (Text "\n " :<>: ShowT t1 :<>: Text "\n/= " :<>: ShowT t2)) ctx)
{-|
Module : Language.Grammars.AspectAG.TH
Description : Boilerplate generation
Copyright : (c) Juan García Garland
License : GPL
Maintainer : jpgarcia@fing.edu.uy
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TemplateHaskell #-}
module Language.Grammars.FastAG.TH where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (showName)
import Data.Proxy
import Data.Either
import GHC.TypeLits
import Data.List
import Data.Set (Set)
import qualified Data.Set as S
import Control.Monad
import Language.Grammars.FastAG
import qualified Data.Kind as DK
-- * Attribute labels
-- | makes a type level lit (Symbol) from a String
str2Sym s = litT$ strTyLit s -- th provides nametoSymbol, btw
-- | TH function to define a typed attribute label given a name
-- and a quoted type
attLabel :: String -> Name -> DecsQ
attLabel s t
= [d| $(varP (mkName s)) = Label :: Label ( 'Att $(str2Sym s)
$(conT t)) |]
-- | for completness, to have a name as the next one
attMono = attLabel
-- | TH function to define a polymorphic attribute
attPoly :: String -> DecsQ
attPoly s
= [d| $(varP (mkName s)) = Label :: forall a . Label ( 'Att $(str2Sym s) a) |]
-- | multiple monomorphic attributes at once
attLabels :: [(String,Name)] -> Q [Dec]
attLabels xs = liftM concat . sequence $ [attLabel att ty | (att,ty) <- xs ]
-- * Non terminals
-- | add a non terminal symbol
addNont :: String -> Q [Dec]
addNont s
= liftM concat . sequence $ [addNTLabel s, addNTType s]
addNTLabel :: String -> Q [Dec]
addNTLabel s
= [d| $(varP (mkName ("nt_" ++ s))) = Label :: Label ('NT $(str2Sym s)) |]
addNTType :: String -> Q [Dec]
addNTType s
= return [TySynD (mkName ("Nt_"++ s)) [] (AppT (PromotedT 'NT) (LitT (StrTyLit s)))]
-- * Productions
--data Symbol = N String | Te Name
type family Terminal s :: Either NT T where
Terminal s = 'Right ('T s)
type family NonTerminal s where
NonTerminal s = 'Left s
data SymTH = Ter Name | NonTer Name | Poly
addChi :: String -- chi name
-> Name -- prd
-> SymTH -- symbol type
-> Q [Dec]
addChi chi prd (Ter typ)
= [d| $(varP (mkName ("ch_" ++chi)))
= Label :: Label ( 'Chi $(str2Sym chi)
$(conT prd)
(Terminal $(conT typ)))|]
addChi chi prd (NonTer typ)
= [d| $(varP (mkName ("ch_" ++chi)))
= Label :: Label ( 'Chi $(str2Sym chi)
$(conT prd)
(NonTerminal $(conT typ)))|]
addChi chi prd poly
= [d| $(varP (mkName ("ch_" ++chi)))
= Label :: forall a . Label ( 'Chi $(str2Sym chi)
$(conT prd)
('Right ('T a)))|]
-- | only prod symbol
addPrd :: String --name
-> Name --nonterm
-> Q [Dec]
addPrd prd nt = liftM concat . sequence
$ [addPrdType prd nt, addPrdLabel prd nt]
addPrdLabel prd nt
= [d| $(varP (mkName ("p_" ++ prd)))
= Label :: Label ('Prd $(str2Sym prd) $(conT nt))|]
addPrdType prd nt
= return [TySynD (mkName ("P_"++ prd)) []
(AppT (AppT (PromotedT 'Prd) (LitT (StrTyLit prd))) (ConT nt))]
-- | Productions
addProd :: String -- name
-> Name -- nt
-> [(String, SymTH)] -- chiLst
-> Q [Dec]
addProd prd nt xs
= liftM concat . sequence $
addPrd prd nt
: addInstance nt prd (map preProc $ xs)
: [addChi chi (mkName ("P_" ++ prd)) sym | (chi, sym) <- xs]
where preProc (n, Ter a) = (mkName n, a)
preProc (n, NonTer a) = (mkName n, a)
preProc (n, Poly) = (mkName n, mkName "a")
-- | class
class Prods (lhs :: NT) (name :: Symbol) (rhs :: [(Symbol, Symbol)]) where {}
-- get a list of instances
getInstances :: Q [InstanceDec]
getInstances = do
ClassI _ instances <- reify ''Prods
return instances
-- convert the list of instances into an Exp so they can be displayed in GHCi
showInstances :: Q Exp
showInstances = do
ins <- getInstances
return . LitE . stringL $ show $ head ins
addInstance :: Name -> String -> [(Name, Name)] -> Q [Dec]
addInstance nt name rhs
= [d| instance Prods $(conT nt) $(str2Sym name) $(typeList rhs) where {} |]
typeList :: [(Name, Name)] -> Q Type
typeList = foldr f promotedNilT
-- where f = \x xs -> appT (appT promotedConsT (nameToSymbolBase x)) xs
where f = \(n,t) xs
-> appT (appT promotedConsT (appT (appT (promotedTupleT 2)
(nameToSymbol n))
(nameToSymbolBase t))) xs
-- where f = \x xs -> if isNTName x
-- then ((appT (appT promotedConsT
-- ((appT [t| Left |]) (conT x))))) xs
-- else ((appT (appT promotedConsT
-- ((appT [t| Right |])
-- (appT [t| 'T |] (conT x)))))) xs
nameToSymbol = litT . strTyLit . show
nameToSymbolBase = litT . strTyLit . nameBase
isNTName :: Name -> Bool
isNTName n
= "Nt_" `isPrefixOf` nameBase n
closeNT :: Name -> Q [Dec]
closeNT nt
= do decs <- getInstances
let consts = map mkCon $ filter (isInstanceOf nt) decs
return [ DataD []
(mkName $ drop 3 $ nameBase nt) [] Nothing
consts [DerivClause Nothing [ConT ''Show, ConT ''Eq, ConT ''Read]]]
isInstanceOf nt (InstanceD _ _ (AppT (AppT (AppT (ConT prods) (ConT nt')) _ ) _) _)
= nameBase nt == nameBase nt'
isInstanceOf _ _ = False
mkCon :: InstanceDec -> Con
mkCon i
= case i of
InstanceD _ [] (AppT (AppT (AppT (ConT _prods) (ConT nt)) (LitT (StrTyLit prdname))) tlist) _
-> RecC (mkName prdname) (map mkBangPR $ getTList tlist)
mkBangP (_, a) = (Bang NoSourceUnpackedness NoSourceStrictness, ConT a)
mkBangPR (n, a) = (n, Bang NoSourceUnpackedness NoSourceStrictness, ConT a)
getTList :: Type -> [(Name, Name)]
getTList (SigT _ _) = []
getTList (AppT (AppT (PromotedConsT)
(AppT (AppT (PromotedTupleT 2)
(LitT (StrTyLit n)))
(LitT (StrTyLit pos))))
ts)
= (mkName n,
if "Nt_" `isPrefixOf` pos then mkName $ drop 3 pos else mkName pos)
: getTList ts
getTList _ = []
-- | keeps nt info
getTListNT :: Type -> [(Name, Name)]
getTListNT (SigT _ _) = []
getTListNT (AppT (AppT (PromotedConsT)
(AppT (AppT (PromotedTupleT 2)
(LitT (StrTyLit n)))
(LitT (StrTyLit pos))))
ts)
= (mkName n, mkName pos) : getTListNT ts
getTListNT _ = []
-- | like |mkCon| in semantic functions, builds a case
mkClause :: InstanceDec -> Clause
mkClause i
= case i of
InstanceD _ [] (AppT (AppT (AppT (ConT _prods)
(ConT nt))
(LitT (StrTyLit prdname)))
tlist) _
-> Clause [VarP (mkName "asp"),
ConP (mkName $ prdname) [ VarP a | a <- (map fst (getTList tlist))]]
(NormalB ((AppE (AppE (AppE (VarE $ mkName "knitAspect")
(VarE $ mkName $ "p_"++ prdname))
(VarE $ mkName "asp"))
(toSemRec $ sortOn fst (getTListNT tlist)))))
[]
toSemRec :: [(Name, Name)] -> Exp
toSemRec
= foldr mkChSem (VarE (mkName "emptyRecord"))
where mkChSem (n,pos) xs
| "Nt_" `isPrefixOf` nameBase pos =
(AppE (AppE (VarE $ mkName ".*.")
(AppE (AppE (VarE $ mkName ".=.")
(VarE $ mkName $ "ch_" ++ nameBase n))
(AppE (AppE (VarE $ mkName $ "sem_" ++ (drop 3 $ nameBase pos))
(VarE $ mkName "asp"))
(VarE $ n))))
xs)
| otherwise =
(AppE (AppE (VarE $ mkName ".*.")
(AppE (AppE (VarE $ mkName ".=.")
(VarE $ mkName $ "ch_" ++ nameBase n))
(AppE (VarE $ mkName "sem_Lit")
(VarE $ n))))
xs)
closeNTs :: [Name] -> Q [Dec]
closeNTs = liftM concat . sequence . map (closeNT)
mkSemFunc :: Name -- nonterm
-> Q [Dec]
mkSemFunc nt =
do decs <- getInstances
let clauses = map mkClause $ filter (isInstanceOf nt) decs
return [FunD (mkName $ "sem_" ++ drop 3 (nameBase nt)) clauses ]
mkSemFuncs :: [Name] -> Q [Dec]
mkSemFuncs
= liftM concat . sequence . map (mkSemFunc)
{-|
Module : Language.Grammars.AspectAG.TPrelude
Description : Some type level functions, needed for AspectAG
Copyright : (c) Juan García Garland, 2018
License : LGPL
Maintainer : jpgarcia@fing.edu.uy
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE GADTs,
KindSignatures,
TypeOperators,
TypeFamilies,
MultiParamTypeClasses,
FlexibleInstances,
FlexibleContexts,
StandaloneDeriving,
UndecidableInstances,
FunctionalDependencies,
ConstraintKinds,
ScopedTypeVariables,
PolyKinds,
DataKinds
#-}
module Language.Grammars.FastAG.TPrelude where
import Data.Kind
import Data.Type.Equality
import GHC.TypeLits
import Data.Proxy
data Label l = Label
sndLabel :: Label '(a,b) -> Label b
sndLabel _ = undefined
getProxy :: a -> Proxy a ; getProxy _ = Proxy
getLabel :: a -> Label a ; getLabel _ = Label
proxyFrom :: t a -> Proxy a
proxyFrom _ = Proxy
-- | If construction, purely computed at type level
type family If (cond:: Bool) (thn :: k) (els :: k) :: k where
If 'True thn els = thn
If 'False thn els = els
-- | Or, purely computed at type level
type family Or (l :: Bool)(r :: Bool) :: Bool where
Or False b = b
Or True b = 'True
-- | And, purely computed at type level
type family And (l :: Bool)(r :: Bool) :: Bool where
And False b = False
And True b = b
-- | Not, purely computed at type level
type family Not (l :: Bool) :: Bool where
Not False = True
Not True = False
-- | LabelSet is a predicate over lists of pairs.
--We assume the list represent a (partial) mapping from k1 to k2.
--k1 is a label, k2 possibly a value.
--The first member of each pair must be unique, this is a predicate of
--well formedness
-- class LabelSet (l :: [(k1,k2)])
type family LabelSetF (r :: [(k, k')]) :: Bool where
LabelSetF '[] = True
LabelSetF '[ '(l, v)] = True
LabelSetF ( '(l, v) ': '(l', v') ': r) = And3 (Not (l == l'))
(LabelSetF ( '(l, v) ': r) )
(LabelSetF ( '(l', v') ': r) )
{-
class LabelSet (r :: [(k, k')]) where {}
instance LabelSetF r ~ True => LabelSet r
-}
type LabelSet r = LabelSetF r ~ True
type family And3 (a1 :: Bool) (a2 :: Bool) (a3 :: Bool) where
And3 True True True = True
And3 _ _ _ = False
-- | Predicate of membership, for lists at type level
type family HMemberT (e::k)(l ::[k]) :: Bool where
HMemberT k '[] = 'False
HMemberT k ( k' ': l) = If (k==k') 'True (HMemberT k l)
-- | Predicate of membership, for labels at type level
type family HasLabelT (l::k) (lst :: [(k,Type)]) :: Bool where
HasLabelT l '[] = 'False
HasLabelT l ( '(k,v) ': tail) = If (l == k) 'True (HasLabelT l tail)
-- |This is used for type Equality
class HEq (x :: k) (y :: k) (b :: Bool) | x y -> b
type HEqK (x :: k1) (y :: k2) (b :: Bool) = HEq (Proxy x) (Proxy y) b
instance ((Proxy x == Proxy y) ~ b) => HEq x y b
type family HEqKF (a :: k)(b :: k) :: Bool
type instance HEqKF a b = a == b
-- | heterogeneous equality at type level
type family (a :: k1) === (b :: k2) where
a === b = (Proxy a) == (Proxy b)
type family TPair (a :: k) b where
TPair a b = '(a, b)
type family LabelsOf (r :: [(k, k')]) :: [k] where
LabelsOf '[] = '[]
LabelsOf ( '(k, ks) ': ls) = k ': LabelsOf ls
type family HasLabel (l :: k) (r :: [(k, k')]) :: Bool where
HasLabel l '[] = False
HasLabel l ( '(l', v) ': r) = Or (l == l') (HasLabel l r)
type family Equal (a:: k)(b :: k') :: Bool where
-- Equal (f a) (g b) = And (Equal f g) (Equal a b)
Equal a a = True
Equal a b = False
type family CMP (a :: k) (b :: k) :: Ordering
type instance CMP (a :: Symbol) (b :: Symbol) = CmpSymbol a b
type instance CMP Bool Char = 'GT