...
 
Commits (7)
......@@ -10,7 +10,7 @@ name: AspectAG
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
version: 0.6.0.0
version: 0.7.0.0
-- A short (one-line) description of the package.
synopsis: Strongly typed Attribute Grammars implemented using type-level programming.
......@@ -97,12 +97,14 @@ library
-- Other library packages from which modules are imported.
build-depends: base >=4.11,
containers >= 0.5,
ghc-prim >= 0.6.1,
mtl >= 2.0,
poly-rec >=0.7,
require >= 0.6.0.0,
singletons >= 2.5.1,
tagged >=0.8,
template-haskell >= 2.13
template-haskell >= 2.13,
type-errors >= 0.2
-- Directories containing source files.
......@@ -110,41 +112,3 @@ library
-- Base language which the package is written in.
default-language: Haskell2010
-- Test-Suite test-Repmin
-- type: exitcode-stdio-1.0
-- main-is: test/Repmin.hs
-- build-depends: base >=4.11 && <4.12,
-- tagged >=0.8 && <0.9,
-- AspectAG >= 0.4,
-- QuickCheck
-- default-language: Haskell2010
-- Test-Suite test-Repmin-TH
-- type: exitcode-stdio-1.0
-- main-is: test/RepminTH.hs
-- build-depends: base >=4.11 && <4.12,
-- tagged >=0.8 && <0.9,
-- AspectAG >= 0.4,
-- QuickCheck
-- default-language: Haskell2010
-- Test-Suite test-Arith
-- type: exitcode-stdio-1.0
-- main-is: test/Arith.hs
-- build-depends: base >=4.11 && <4.12,
-- containers >= 0.5,
-- tagged >=0.8 && <0.9,
-- AspectAG >= 0.4,
-- QuickCheck
-- default-language: Haskell2010
-- Test-Suite test-Graphs
-- type: exitcode-stdio-1.0
-- main-is: test/Graphs.hs
-- build-depends: base >=4.11 && <4.12,
-- tagged >=0.8 && <0.9,
-- AspectAG >= 0.4,
-- containers >= 0.5,
-- QuickCheck
-- default-language: Haskell2010
This diff is collapsed.
......@@ -23,14 +23,15 @@
PartialTypeSignatures,
TemplateHaskell,
InstanceSigs,
EmptyCase
EmptyCase,
StandaloneKindSignatures
#-}
module Language.Grammars.AspectAG.RecordInstances where
import Data.GenRec
import Data.Type.Require hiding (ShowTE)
import GHC.TypeLits
import Data.Type.Require
--import GHC.TypeLits
import Data.Kind
import Data.Proxy
import GHC.TypeLits
......@@ -42,39 +43,42 @@ import Data.Singletons.TypeLits
import Data.Singletons.Prelude.Ord
import Data.Singletons.Prelude.Eq
import Data.Singletons.CustomStar
import Data.Singletons.TypeLits
data Att = Att Symbol Type -- deriving Eq
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
data T = T Type
prdFromChi :: Sing (Chi nam prd tnt) -> Sing prd
prdFromChi _ = undefined -- Label
data instance Sing (att :: Att) where
SAtt :: Sing s -> Sing t -> Sing ('Att s t)
data instance Sing (prod :: Prod) where
SPrd :: Sing s -> Sing nt -> Sing ('Prd s nt)
data instance Sing (child :: Child) where
data SAtt (att :: Att) where
SAtt :: Sing s -> Sing t -> SAtt ('Att s t)
data SProd (prod :: Prod) where
SPrd :: Sing s -> Sing nt -> SProd ('Prd s nt)
data SChild (child :: Child) where
SChi :: Sing s -> Sing prd -> Sing (tnt :: Either NT T)
-> Sing ('Chi s prd tnt)
data instance Sing (nt :: NT) where
SNT :: Sing s -> Sing ('NT s)
data instance Sing (nt :: T) where
ST :: Sing t -> Sing ('T t)
-> SChild ('Chi s prd tnt)
data SNT (nt :: NT) where
SNT :: Sing s -> SNT ('NT s)
data ST (nt :: T) where
ST :: Sing t -> ST ('T t )
data Lhs = Lhs
data instance Sing (lhs :: Lhs) where
SLhs :: Sing 'Lhs
lhs = SLhs
data SLhs (lhs :: Lhs) where
SLhs :: SLhs 'Lhs
instance (KnownSymbol s) => SingI ('Prd s nt) where
sing = SPrd SSym undefined
type instance Sing @Att = SAtt
type instance Sing @Prod = SProd
type instance Sing @Child = SChild
type instance Sing @NT = SNT
type instance Sing @T = ST
type instance Sing @Lhs = SLhs
-- $(singletonStar [''Bool, ''Maybe, ''Either, ''Char,
-- ''Int, ''Integer, ''String])
lhs = SLhs
instance PEq Type where
type instance a == b = 'True
......@@ -104,6 +108,7 @@ type instance ShowTE ('T l) = Text "Terminal " :<>: ShowTE l
-- | * Records
-- | datatype definition
......@@ -283,3 +288,21 @@ data PrdReco
type Aspect (asp :: [(Prod, Type)]) = Rec PrdReco asp
type instance ShowRec PrdReco = "Aspect"
type instance ShowField PrdReco = "production named "
-- * Productions
type family Terminal s :: Either NT T where
Terminal s = 'Right ('T s)
type family NonTerminal s where
NonTerminal s = 'Left s
prodFromChi :: (KnownSymbol prd, SingI nt) =>
Sing (Chi ch ('Prd prd nt) (NonTerminal nt')) -> Sing ('Prd prd nt)
prodFromChi _ = sing
instance (KnownSymbol s, SingI nt) => SingI (Prd s nt :: Prod) where
sing = SPrd sing sing
instance (KnownSymbol s) => SingI ('NT s :: NT) where
sing = SNT sing
......@@ -31,6 +31,8 @@ module Language.Grammars.AspectAG.TH where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (showName)
import Data.Singletons.TypeLits
import Data.Singletons.Prelude.Either
import Data.Proxy
import Data.Either
import GHC.TypeLits
......@@ -40,7 +42,6 @@ import qualified Data.Set as S
import Control.Monad
import Data.GenRec.Label
import Data.GenRec
import Language.Grammars.AspectAG
import Language.Grammars.AspectAG.RecordInstances
......@@ -57,16 +58,16 @@ str2Sym s = litT$ strTyLit s -- th provides nametoSymbol, btw
-- and a quoted type
attLabel :: String -> Name -> DecsQ
attLabel s t
= [d| $(varP (mkName s)) = Label :: Label ( 'Att $(str2Sym s)
= [d| $(varP (mkName s)) = SAtt SSym sing :: Sing ( '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) |]
--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]
......@@ -81,20 +82,13 @@ addNont s
addNTLabel :: String -> Q [Dec]
addNTLabel s
= [d| $(varP (mkName ("nt_" ++ s))) = Label :: Label ('NT $(str2Sym s)) |]
= [d| $(varP (mkName ("nt_" ++ s))) = SNT SSym :: Sing ('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
......@@ -106,19 +100,21 @@ addChi :: String -- chi name
-> Q [Dec]
addChi chi prd (Ter typ)
= [d| $(varP (mkName ("ch_" ++chi)))
= Label :: Label ( 'Chi $(str2Sym chi)
$(conT prd)
(Terminal $(conT typ)))|]
= SChi SSym $(varE (mkName ("p_" ++ drop 2 (nameBase prd)))) (SRight $ ST sing )
:: Sing ( '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)))|]
= SChi SSym $(varE (mkName ("p_" ++ drop 2 (nameBase prd)))) (SLeft $ SNT SSym )
:: Sing ( '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
......@@ -129,7 +125,8 @@ addPrd prd nt = liftM concat . sequence
addPrdLabel prd nt
= [d| $(varP (mkName ("p_" ++ prd)))
= Label :: Label ('Prd $(str2Sym prd) $(conT nt))|]
= SPrd SSym $(varE (mkName ("nt_" ++ drop 3 (nameBase nt))))
:: Sing ('Prd $(str2Sym prd) $(conT nt))|]
addPrdType prd nt
= return [TySynD (mkName ("P_"++ prd)) []
......