{-|
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.AspectAG.TH where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax (showName, location, Loc(..), Q, Exp, lift)
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.Haskell.TH.Ppr (pprint)

import Data.GenRec.Label
import Data.GenRec
import Language.Grammars.AspectAG
import Language.Grammars.AspectAG.RecordInstances
import qualified Data.Kind as DK

import Debug.Trace.LocationTH


-- * Attribute labels

-- | makes a type level lit (Symbol) from a String
str2Sym :: String -> TypeQ
str2Sym String
s = TyLitQ -> TypeQ
litT(TyLitQ -> TypeQ) -> TyLitQ -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> TyLitQ
strTyLit String
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 :: String -> Name -> DecsQ
attLabel String
s Name
t
  = [d| $(varP (mkName s)) = Label :: Label ( 'Att $(str2Sym s)
                                            $(conT t)) |]

-- | for completness, to have a name as the next one
attMono :: String -> Name -> DecsQ
attMono = String -> Name -> DecsQ
attLabel

-- | TH function to define a polymorphic attribute
attPoly :: String -> DecsQ
attPoly :: String -> DecsQ
attPoly String
s
    = [d| $(varP (mkName s)) = Label :: forall a . Label ( 'Att $(str2Sym s) a) |]

-- | multiple monomorphic attributes at once
attLabels :: [(String,Name)] -> Q [Dec]
attLabels :: [(String, Name)] -> DecsQ
attLabels [(String, Name)]
xs = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> ([DecsQ] -> Q [[Dec]]) -> [DecsQ] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([DecsQ] -> DecsQ) -> [DecsQ] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [String -> Name -> DecsQ
attLabel String
att Name
ty | (String
att,Name
ty) <- [(String, Name)]
xs ]

-- * Non terminals

-- | add a non terminal symbol
addNont :: String -> Q [Dec]
addNont :: String -> DecsQ
addNont String
s
  = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> ([DecsQ] -> Q [[Dec]]) -> [DecsQ] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([DecsQ] -> DecsQ) -> [DecsQ] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [String -> DecsQ
addNTLabel String
s, String -> DecsQ
addNTType String
s]

addNTLabel :: String -> Q [Dec]
addNTLabel :: String -> DecsQ
addNTLabel String
s
  = [d| $(varP (mkName ("nt_" ++ s))) = Label :: Label ('NT $(str2Sym s)) |]

addNTType :: String -> Q [Dec]
addNTType :: String -> DecsQ
addNTType String
s
  = [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> [TyVarBndr] -> Type -> Dec
TySynD (String -> Name
mkName (String
"Nt_"String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)) [] (Type -> Type -> Type
AppT (Name -> Type
PromotedT 'NT) (TyLit -> Type
LitT (String -> TyLit
StrTyLit String
s)))]


data SymTH = Ter Name | NonTer Name | Poly


addChi  :: String -- chi name
        -> Name   -- prd
        -> SymTH  -- symbol type
        -> Q [Dec]
addChi :: String -> Name -> SymTH -> DecsQ
addChi String
chi Name
prd (Ter Name
typ)
  = [d| $(varP (mkName ("ch_" ++chi)))
           = Label :: Label ( 'Chi $(str2Sym chi)
                                   $(conT prd)
                                    (Terminal $(conT typ)))|]
addChi String
chi Name
prd (NonTer Name
typ)
  = [d| $(varP (mkName ("ch_" ++chi)))
           = Label :: Label ( 'Chi $(str2Sym chi)
                                   $(conT prd)
                                    (NonTerminal $(conT typ)))|]
addChi String
chi Name
prd SymTH
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 :: String -> Name -> DecsQ
addPrd String
prd Name
nt = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> ([DecsQ] -> Q [[Dec]]) -> [DecsQ] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
              ([DecsQ] -> DecsQ) -> [DecsQ] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [String -> Name -> DecsQ
forall (m :: * -> *). Monad m => String -> Name -> m [Dec]
addPrdType String
prd Name
nt, String -> Name -> DecsQ
addPrdLabel String
prd Name
nt]

addPrdLabel :: String -> Name -> DecsQ
addPrdLabel String
prd Name
nt
  = [d| $(varP (mkName ("p_" ++ prd)))
         = Label :: Label ('Prd $(str2Sym prd) $(conT nt))|]

addPrdType :: String -> Name -> m [Dec]
addPrdType String
prd Name
nt
  = [Dec] -> m [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> [TyVarBndr] -> Type -> Dec
TySynD (String -> Name
mkName (String
"P_"String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prd)) []
            (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
PromotedT 'Prd) (TyLit -> Type
LitT (String -> TyLit
StrTyLit String
prd))) (Name -> Type
ConT Name
nt))]


-- | Productions
addProd :: String             -- name
        -> Name               -- nt
        -> [(String, SymTH)]  -- chiLst
        -> Q [Dec]
addProd :: String -> Name -> [(String, SymTH)] -> DecsQ
addProd String
prd Name
nt [(String, SymTH)]
xs
  = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> ([DecsQ] -> Q [[Dec]]) -> [DecsQ] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([DecsQ] -> DecsQ) -> [DecsQ] -> DecsQ
forall a b. (a -> b) -> a -> b
$
      String -> Name -> DecsQ
addPrd String
prd Name
nt
    DecsQ -> [DecsQ] -> [DecsQ]
forall a. a -> [a] -> [a]
: Name -> String -> [(Name, Name)] -> DecsQ
addInstance Name
nt String
prd (((String, SymTH) -> (Name, Name))
-> [(String, SymTH)] -> [(Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (String, SymTH) -> (Name, Name)
preProc [(String, SymTH)]
xs)
    DecsQ -> [DecsQ] -> [DecsQ]
forall a. a -> [a] -> [a]
: [String -> Name -> SymTH -> DecsQ
addChi String
chi (String -> Name
mkName (String
"P_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prd)) SymTH
sym | (String
chi, SymTH
sym) <- [(String, SymTH)]
xs]
    where preProc :: (String, SymTH) -> (Name, Name)
preProc (String
n, Ter Name
a)    = (String -> Name
mkName String
n, Name
a)
          preProc (String
n, NonTer Name
a) = (String -> Name
mkName String
n, Name
a)
          preProc (String
n, SymTH
Poly)     = (String -> Name
mkName String
n, String -> Name
mkName String
"a")

-- | class
class Prods (lhs :: NT) (name :: Symbol) (rhs :: [(Symbol, Symbol)]) where {}

-- get a list of instances
getInstances :: Q [InstanceDec]
getInstances :: DecsQ
getInstances = do
  ClassI Dec
_ [Dec]
instances <- Name -> Q Info
reify ''Prods
  [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
instances

-- convert the list of instances into an Exp so they can be displayed in GHCi
showInstances :: Q Exp
showInstances :: Q Exp
showInstances = do
  [Dec]
ins <- DecsQ
getInstances
  Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> (String -> Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Dec -> String
forall a. Show a => a -> String
show (Dec -> String) -> Dec -> String
forall a b. (a -> b) -> a -> b
$ [Dec] -> Dec
forall a. [a] -> a
head [Dec]
ins

addInstance :: Name -> String -> [(Name, Name)] -> Q [Dec]
addInstance :: Name -> String -> [(Name, Name)] -> DecsQ
addInstance Name
nt String
name [(Name, Name)]
rhs
  = [d| instance Prods $(conT nt) $(str2Sym name) $(typeList rhs) where {}  |]

typeList :: [(Name, Name)] -> Q Type
typeList :: [(Name, Name)] -> TypeQ
typeList = ((Name, Name) -> TypeQ -> TypeQ)
-> TypeQ -> [(Name, Name)] -> TypeQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name, Name) -> TypeQ -> TypeQ
forall a. Show a => (a, Name) -> TypeQ -> TypeQ
f TypeQ
promotedNilT
    -- where f = \x xs -> appT (appT promotedConsT (nameToSymbolBase x)) xs
  where f :: (a, Name) -> TypeQ -> TypeQ
f = \(a
n,Name
t) TypeQ
xs
          -> TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT TypeQ
promotedConsT (TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ
appT (Int -> TypeQ
promotedTupleT Int
2)
                                              (a -> TypeQ
forall a. Show a => a -> TypeQ
nameToSymbol a
n))
                                       (Name -> TypeQ
nameToSymbolBase Name
t))) TypeQ
xs

nameToSymbol :: a -> TypeQ
nameToSymbol = TyLitQ -> TypeQ
litT (TyLitQ -> TypeQ) -> (a -> TyLitQ) -> a -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLitQ
strTyLit (String -> TyLitQ) -> (a -> String) -> a -> TyLitQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
nameToSymbolBase :: Name -> TypeQ
nameToSymbolBase = TyLitQ -> TypeQ
litT (TyLitQ -> TypeQ) -> (Name -> TyLitQ) -> Name -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLitQ
strTyLit (String -> TyLitQ) -> (Name -> String) -> Name -> TyLitQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

isNTName :: Name -> Bool
isNTName :: Name -> Bool
isNTName Name
n
  = String
"Nt_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Name -> String
nameBase Name
n

closeNT :: Name -> Q [Dec]
closeNT :: Name -> DecsQ
closeNT Name
nt
  = do [Dec]
decs <- DecsQ
getInstances
       let consts :: [Con]
consts = (Dec -> Con) -> [Dec] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Con
mkCon ([Dec] -> [Con]) -> [Dec] -> [Con]
forall a b. (a -> b) -> a -> b
$ (Dec -> Bool) -> [Dec] -> [Dec]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Dec -> Bool
isInstanceOf Name
nt) [Dec]
decs
       [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [ Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD []
                (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
3 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
nt) [] Maybe Type
forall a. Maybe a
Nothing
                [Con]
consts [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Type
ConT ''Show, Name -> Type
ConT ''Eq, Name -> Type
ConT ''Read]]]

isInstanceOf :: Name -> Dec -> Bool
isInstanceOf Name
nt (InstanceD Maybe Overlap
_ Cxt
_ (AppT (AppT (AppT (ConT Name
prods) (ConT Name
nt')) Type
_ ) Type
_) [Dec]
_)
  = Name -> String
nameBase Name
nt String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> String
nameBase Name
nt'
isInstanceOf Name
_ Dec
_ = Bool
False

mkCon :: InstanceDec -> Con
mkCon :: Dec -> Con
mkCon Dec
i
  = case Dec
i of
  InstanceD Maybe Overlap
_ [] (AppT (AppT (AppT (ConT Name
_prods) (ConT Name
nt)) (LitT (StrTyLit String
prdname))) Type
tlist) [Dec]
_
    -> Name -> [VarBangType] -> Con
RecC (String -> Name
mkName String
prdname) (((Name, Name) -> VarBangType) -> [(Name, Name)] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Name) -> VarBangType
forall a. (a, Name) -> (a, Bang, Type)
mkBangPR ([(Name, Name)] -> [VarBangType])
-> [(Name, Name)] -> [VarBangType]
forall a b. (a -> b) -> a -> b
$ Type -> [(Name, Name)]
getTList Type
tlist)

mkBangP :: (a, Name) -> (Bang, Type)
mkBangP  (a
_, Name
a) = (SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Name -> Type
ConT Name
a)
mkBangPR :: (a, Name) -> (a, Bang, Type)
mkBangPR (a
n, Name
a) = (a
n, SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Name -> Type
ConT Name
a)

getTList :: Type -> [(Name, Name)]
getTList :: Type -> [(Name, Name)]
getTList (SigT Type
_ Type
_) = []
getTList (AppT (AppT (Type
PromotedConsT)
                (AppT (AppT (PromotedTupleT Int
2)
                       (LitT (StrTyLit String
n)))
                  (LitT (StrTyLit String
pos))))
           Type
ts)
  = (String -> Name
mkName String
n,
     if String
"Nt_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
pos then String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
3 String
pos else String -> Name
mkName String
pos)
    (Name, Name) -> [(Name, Name)] -> [(Name, Name)]
forall a. a -> [a] -> [a]
: Type -> [(Name, Name)]
getTList Type
ts
getTList Type
_ = []

-- | keeps nt info
getTListNT :: Type -> [(Name, Name)]
getTListNT :: Type -> [(Name, Name)]
getTListNT (SigT Type
_ Type
_) = []
getTListNT (AppT (AppT (Type
PromotedConsT)
                (AppT (AppT (PromotedTupleT Int
2)
                       (LitT (StrTyLit String
n)))
                  (LitT (StrTyLit String
pos))))
           Type
ts)
  = (String -> Name
mkName String
n, String -> Name
mkName String
pos) (Name, Name) -> [(Name, Name)] -> [(Name, Name)]
forall a. a -> [a] -> [a]
: Type -> [(Name, Name)]
getTListNT Type
ts
getTListNT Type
_ = []

-- | like |mkCon| in semantic functions, builds a case
mkClause :: InstanceDec -> Clause
mkClause :: Dec -> Clause
mkClause Dec
i
  = case Dec
i of
  InstanceD Maybe Overlap
_ [] (AppT (AppT (AppT (ConT Name
_prods)
                               (ConT Name
nt))
                         (LitT (StrTyLit String
prdname)))
                   Type
tlist) [Dec]
_
    -> [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP (String -> Name
mkName String
"asp"),
               Name -> [Pat] -> Pat
ConP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
prdname) [ Name -> Pat
VarP Name
a | Name
a <- ((Name, Name) -> Name) -> [(Name, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Name) -> Name
forall a b. (a, b) -> a
fst (Type -> [(Name, Name)]
getTList Type
tlist)]]
    (Exp -> Body
NormalB ((Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"knitAspect")
                           (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"p_"String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prdname))
                      (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"asp"))
                ([(Name, Name)] -> Exp
toSemRec (Type -> [(Name, Name)]
getTListNT Type
tlist)))))
    []

toSemRec :: [(Name, Name)] -> Exp
toSemRec :: [(Name, Name)] -> Exp
toSemRec
  = ((Name, Name) -> Exp -> Exp) -> Exp -> [(Name, Name)] -> Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name, Name) -> Exp -> Exp
mkChSem (Name -> Exp
VarE (String -> Name
mkName String
"emptyGenRec"))
  where mkChSem :: (Name, Name) -> Exp -> Exp
mkChSem (Name
n,Name
pos) Exp
xs
          | String
"Nt_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` Name -> String
nameBase Name
pos =
          (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
".*.")
                 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
".=.")
                        (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"ch_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n))
                   (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"sem_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
3 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
pos))
                          (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"asp"))
                     (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Name
n))))
            Exp
xs)
          | Bool
otherwise =
            (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
".*.")
                   (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
".=.")
                          (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"ch_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n))
                    (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"sem_Lit")
                      (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Name
n))))
            Exp
xs)
closeNTs :: [Name] -> Q [Dec]
closeNTs :: [Name] -> DecsQ
closeNTs = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> ([Name] -> Q [[Dec]]) -> [Name] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([DecsQ] -> Q [[Dec]])
-> ([Name] -> [DecsQ]) -> [Name] -> Q [[Dec]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> DecsQ) -> [Name] -> [DecsQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> DecsQ
closeNT)

mkSemFunc :: Name -- nonterm
          -> Q [Dec]
mkSemFunc :: Name -> DecsQ
mkSemFunc Name
nt =
  do [Dec]
decs <- DecsQ
getInstances
     let clauses :: [Clause]
clauses = (Dec -> Clause) -> [Dec] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Clause
mkClause ([Dec] -> [Clause]) -> [Dec] -> [Clause]
forall a b. (a -> b) -> a -> b
$ (Dec -> Bool) -> [Dec] -> [Dec]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Dec -> Bool
isInstanceOf Name
nt) [Dec]
decs
     [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> [Clause] -> Dec
FunD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"sem_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
3 (Name -> String
nameBase Name
nt)) [Clause]
clauses ]

mkSemFuncs :: [Name] -> Q [Dec]
mkSemFuncs :: [Name] -> DecsQ
mkSemFuncs
  = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> ([Name] -> Q [[Dec]]) -> [Name] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([DecsQ] -> Q [[Dec]])
-> ([Name] -> [DecsQ]) -> [Name] -> Q [[Dec]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> DecsQ) -> [Name] -> [DecsQ]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> DecsQ
mkSemFunc)


here :: Q Exp
here :: Q Exp
here = Q Loc
location Q Loc -> (Loc -> Q Exp) -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Loc
loc -> [e| Proxy @( Text $(str2Sym . ppLoc $ loc) ) |]
 where
   ppLoc :: Loc -> String
ppLoc (Loc String
file String
_pack String
mod (Int
line, Int
startcol) (Int
_line', Int
endcol)) =
     String
"   location: (module: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mod String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", line:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" cols: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
show (Int
startcol, Int
endcol) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"