{-# 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.AspectAG.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.AspectAG
import qualified Data.Kind as DK
import qualified Language.Haskell.TH.Compat.Strict as Comp
str2Sym s = litT$ strTyLit s
attLabel :: String -> Name -> DecsQ
attLabel s t
= [d| $(varP (mkName s)) = Label :: Label ( 'Att $(str2Sym s)
$(conT t)) |]
attMono = attLabel
attPoly :: String -> DecsQ
attPoly s
= [d| $(varP (mkName s)) = Label :: forall a . Label ( 'Att $(str2Sym s) a) |]
attLabels :: [(String,Name)] -> Q [Dec]
attLabels xs = liftM concat . sequence $ [attLabel att ty | (att,ty) <- xs ]
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)))]
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
-> Name
-> SymTH
-> 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)))|]
addPrd :: String
-> Name
-> 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))]
addProd :: String
-> Name
-> [(String, SymTH)]
-> 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)
class Prods (lhs :: NT) (name :: Symbol) (rhs :: [(Symbol, Symbol)]) where {}
getInstances :: Q [InstanceDec]
getInstances = do
ClassI _ instances <- reify ''Prods
return instances
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 = \(n,t) xs
-> appT (appT promotedConsT (appT (appT (promotedTupleT 2)
(nameToSymbol n))
(nameToSymbolBase t))) 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 _ = []
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 _ = []
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 (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
-> Q [Dec]
mkSemFunc nt =
do decs <- getInstances
let clauses = map mkClause $ filter (isInstanceOf nt) decs
return [FunD (mkName $ "sem_" ++ drop 3 (nameBase nt)) clauses ]