module FormalLanguage.CFG.TH
( thCodeGen
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception (assert)
import Control.Lens hiding (Strict, (...), outside)
import Control.Monad
import Control.Monad.State.Strict as M
import Control.Monad.Trans.Class
import Data.Char (toUpper,toLower)
import Data.Default
import Data.Function (on)
import Data.List (intersperse,nub,nubBy,groupBy)
import Data.Maybe
import Data.Vector.Fusion.Stream.Monadic (Stream)
import GHC.Exts (the)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax hiding (lift)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import Text.Printf
import Control.Monad.Reader
import ADP.Fusion ( (%), (|||), (...), (<<<) )
import qualified ADP.Fusion as ADP
import Data.PrimitiveArray (Z(..), (:.)(..))
import FormalLanguage.CFG.Grammar
import FormalLanguage.CFG.PrettyPrint.ANSI
data CfgState = CfgState
{ _qGrammar :: Grammar
, _qElemTyName :: Name
, _qGrammarName :: Name
, _qMTyName :: Name
, _qRetTyName :: Name
, _qSigName :: Name
, _qAttribFuns :: M.Map [AttributeFunction] VarStrictType
, _qChoiceFun :: VarStrictType
, _qPartialSyntVarNames :: M.Map Symbol Name
, _qInsideSyntVarNames :: M.Map Symbol Name
, _qFullSyntVarNames :: M.Map Symbol Name
, _qTermAtomVarNames :: M.Map (String,Int) Name
, _qTermAtomTyNames :: M.Map String Name
, _qTermSymbExp :: M.Map Symbol (Type,Exp)
, _qPrefix :: String
}
makeLenses ''CfgState
instance Default CfgState where
def = CfgState
{ _qGrammar = error "def / grammar"
, _qGrammarName = error "def / grammarname"
, _qElemTyName = error "def / elemty"
, _qRetTyName = error "def / retty"
, _qMTyName = error "def / mty"
, _qSigName = error "def / signame"
, _qTermAtomTyNames = error "def / termtynames"
, _qFullSyntVarNames = error "def / synbodynames"
, _qAttribFuns = error "def / attribfuns"
, _qChoiceFun = error "def / choicefun"
, _qTermSymbExp = error "def / termsymbexp"
, _qTermAtomVarNames = error "def / termsingvarnames"
, _qPartialSyntVarNames = error "def / partsyntvarnames"
, _qInsideSyntVarNames = error "def / insidesyntvarnames"
, _qPrefix = error "def / prefix"
}
type TQ z = StateT CfgState Q z
thCodeGen :: Int -> Grammar -> Q [Dec]
thCodeGen prefixLen g = do
let _qGrammar = g
_qMTyName <- newName "m"
_qElemTyName <- newName "s"
_qRetTyName <- newName "r"
_qTermAtomTyNames <- M.fromList <$> (mapM (\t -> (t,) <$> newName ("t_" ++ t)) $ g^..termvars.folded.name.getSteName)
_qPartialSyntVarNames <- M.fromList <$> (mapM (\n -> (n,) <$> newName ("s_" ++ (n^..getSymbolList.folded.name.getSteName.folded))) $ uniqueSyntacticSymbols g)
_qInsideSyntVarNames <- M.fromList <$> (mapM (\n -> (n,) <$> newName ("i_" ++ (n^..getSymbolList.folded.name.getSteName.folded))) $ uniqueSynTermSymbols g)
let _qPrefix = over _head toLower $ take prefixLen (g^.grammarName)
evalStateT codeGen def{_qGrammar, _qMTyName, _qElemTyName, _qRetTyName, _qTermAtomTyNames, _qPartialSyntVarNames, _qInsideSyntVarNames, _qPrefix}
codeGen :: TQ [Dec]
codeGen = do
qTermAtomVarNames <~ M.fromList <$> dimensionalTermSymbNames
qTermSymbExp <~ M.fromList <$> (mapM grammarTermExpression =<< uniqueTerminalSymbols <$> use qGrammar)
qAttribFuns <~ (use (qGrammar.rules) >>= (fmap M.fromList . mapM attributeFunctionType . S.toList))
qChoiceFun <~ choiceFunction
sig <- signature
gra <- grammar
inl <- use qGrammarName >>= \gname -> lift $ pragInlD gname Inline FunLike AllPhases
g <- use qGrammar
if False
then return [gra,inl]
else return [sig,gra,inl]
signature :: TQ Dec
signature = do
m <- use qMTyName
x <- use qElemTyName
r <- use qRetTyName
termNames <- use qTermAtomTyNames
sigName <- (mkName . ("Sig" ++)) <$> use (qGrammar.grammarName)
fs <- use qAttribFuns
h <- use qChoiceFun
qSigName .= sigName
lift $ dataD (cxt [])
sigName
(PlainTV m : PlainTV x : PlainTV r : (map PlainTV $ termNames^..folded))
[recC sigName ((map return $ fs^..folded) ++ [return h])]
[]
grammarArguments :: TQ [PatQ]
grammarArguments = do
g <- use qGrammar
signame <- use qSigName
h <- use qChoiceFun
fs <- use qAttribFuns
tavn <- use qTermAtomVarNames
psyn <- use qPartialSyntVarNames
isyn <- use qInsideSyntVarNames
let alg = recP signame [ fieldPat n (varP n) | (n,_,_) <- h:(fs^..folded) ]
let syn = [ varP s | s <- psyn^..folded ]
let isn = [ bangP $ varP s | s <- isyn^..folded ]
let ter = [ bangP $ varP t | t <- tavn^..folded ]
gname <- showName <$> use qGrammarName
let ppSynt [x] = PP.red $ PP.text x
ppSynt xs = PP.list $ map (ppSynt . (:[])) xs
ppTerm (n,k) = PP.yellow . PP.text $ printf "%s,%d" n k
pp = PP.dullgreen $ PP.text (printf "%s $ALGEBRA" gname)
sy = PP.encloseSep (PP.text " ") (PP.empty) (PP.text " ") (runReader (mapM symbolDoc $ M.keys psyn) g)
iy = if M.null isyn then PP.text "" else PP.encloseSep (PP.text " ") (PP.empty) (PP.text " ") (runReader (mapM symbolDoc $ M.keys isyn) g)
te = PP.encloseSep (PP.text " ") (PP.empty) (PP.text " ") (map (\s -> ppTerm $ s) $ M.keys tavn)
lift . runIO . printDoc $ pp PP.<> sy PP.<> iy PP.<> te PP.<> PP.hardline
return $ alg : syn ++ isn ++ ter
grammarBodyWhere :: TQ [DecQ]
grammarBodyWhere = do
ls <- (nub . map _lhs . S.elems) <$> use (qGrammar.rules)
synKeys <- (filter (`elem` ls) . M.keys) <$> use qPartialSyntVarNames
bodySynNames <- lift $ sequence [ (n,) <$> (newName $ "ss_" ++ concat k) | n <- synKeys, let k = n^..getSymbolList.folded.name.getSteName ]
qFullSyntVarNames .= M.fromList bodySynNames
mapM grammarBodySyn bodySynNames
grammarBodySyn :: (Symbol,Name) -> TQ DecQ
grammarBodySyn (s,n) = do
hname <- use (qChoiceFun._1)
partial <- use qPartialSyntVarNames
ix <- lift $ newName "ix"
fs <- (filter ((s==) . _lhs) . S.elems) <$> use (qGrammar.rules)
rs <- mapM grammarBodyRHS fs
let rhs = assert (not $ null rs) $
appE ( uInfixE (foldl1 (\acc z -> uInfixE acc (varE '(|||)) z) rs)
(varE '(...))
(varE hname) )
(varE ix)
return $ valD (varP n) (normalB $ appE (varE $ M.findWithDefault (error "grammarBodySyn") s partial) (lamE [varP ix] rhs)) []
grammarBodyRHS :: Rule -> TQ ExpQ
grammarBodyRHS (Rule _ f rs) = do
terms <- use qTermSymbExp
synNames <- use qFullSyntVarNames
synTermNames <- use qInsideSyntVarNames
let genSymbol s
| isTerminal s = return . snd $ M.findWithDefault (error "grammarBodyRHS") s terms
| isSyntactic s = return . VarE $ M.findWithDefault (error "grammarBodyRHS") s (synNames)
| isSynTerm s = return . VarE $ M.findWithDefault (error "grammarBodyRHS") s (synTermNames)
let rhs = assert (not $ null rs) $ foldl1 (\acc z -> uInfixE acc (varE '(%)) z) . map genSymbol $ rs
Just (fname,_,_) <- use (qAttribFuns . at f)
return $ appE (appE (varE '(<<<)) (varE $ fname)) rhs
grammarTermExpression :: Symbol -> TQ (Symbol, (Type,Exp))
grammarTermExpression s = do
ttypes <- use qTermAtomTyNames
tavn <- use qTermAtomVarNames
let genType :: [SynTermEps] -> TypeQ
genType z
| [Deletion] <- z = [t| () |]
| [Epsilon ] <- z = [t| () |]
| [Term tnm tidx] <- z = varT $ ttypes M.! (tnm^.getSteName)
| xs <- z = foldl (\acc z -> [t| $acc :. $(genType [z]) |]) [t| Z |] xs
let genExp :: [SynTermEps] -> ExpQ
genExp z
| [Deletion] <- z = [| ADP.Deletion |]
| [Epsilon ] <- z = [| ADP.Epsilon |]
| [Term tnm tidx] <- z = varE $ tavn M.! (tnm^.getSteName,0)
| xs <- z = foldl (\acc (k,z) -> [| $acc ADP.:| $(case z of { Deletion -> [| ADP.Deletion |]
; Epsilon -> [| ADP.Epsilon |]
; Term tnm tidx -> varE $ tavn M.! (tnm^.getSteName,k)
}) |])
[| ADP.M |] $ zip [0..] xs
ty <- lift . genType $ s^.getSymbolList
ex <- lift . genExp $ s^.getSymbolList
return (s, (ty,ex))
dimensionalTermSymbNames :: TQ [((String,Int),Name)]
dimensionalTermSymbNames = do
g <- use qGrammar
ys <- forM (uniqueBindableTermsWithTape g) $ \(t,d) -> do
let sn = t^.name.getSteName
let dm = d^.getTape
( (sn,dm) , ) <$> (lift $ newName $ "term" ++ sn ++ show dm)
return ys
grammar :: TQ Dec
grammar = do
gn <- (mkName . ("g" ++) . _grammarName) <$> use qGrammar
qGrammarName .= gn
args <- grammarArguments
bodyWhere <- grammarBodyWhere
bodyNames <- use qFullSyntVarNames
let body = normalB . foldl (\acc z -> [| $acc :. $z |]) [|Z|] . map varE $ bodyNames^..folded
lift $ funD gn [clause args body bodyWhere]
attributeFunctionType :: Rule -> TQ ([AttributeFunction],VarStrictType)
attributeFunctionType r = do
let (f:fs) = r^..attr.folded
elemTyName <- use qElemTyName
terminal <- use qTermSymbExp
let argument :: Symbol -> Type
argument s
| isSyntactic s = VarT elemTyName
| isSynTerm s = VarT elemTyName
| isTerminal s = fst $ terminal M.! s
prefix <- use qPrefix
let attrFun = over _head toLower (f^.getAttr) ++ concatMap (over _head toUpper) (fs^..folded.getAttr)
nm <- lift $ (return . mkName) $ if null prefix
then attrFun
else prefix ++ over _head toUpper attrFun
let tp = foldr AppT (VarT elemTyName) $ map (AppT ArrowT . argument) $ r^.rhs
return (f:fs, (nm,NotStrict,tp))
choiceFunction :: TQ VarStrictType
choiceFunction = do
elemTyName <- use qElemTyName
retTyName <- use qRetTyName
mTyName <- use qMTyName
let args = AppT ArrowT $ AppT (AppT (ConT ''Stream) (VarT mTyName)) (VarT elemTyName)
let rtrn = AppT (VarT mTyName) (VarT retTyName)
prefix <- use qPrefix
let hFun = if null prefix then "h" else prefix ++ "H"
return (mkName hFun, NotStrict, AppT args rtrn)