diff --git a/FormalGrammars.cabal b/FormalGrammars.cabal --- a/FormalGrammars.cabal +++ b/FormalGrammars.cabal @@ -1,5 +1,5 @@ name: FormalGrammars -version: 0.0.0.1 +version: 0.0.0.2 author: Christian Hoener zu Siederdissen, 2013 copyright: Christian Hoener zu Siederdissen, 2013 homepage: http://www.tbi.univie.ac.at/~choener/gramprod/ diff --git a/FormalLanguage/CFG/Grammar.hs b/FormalLanguage/CFG/Grammar.hs --- a/FormalLanguage/CFG/Grammar.hs +++ b/FormalLanguage/CFG/Grammar.hs @@ -34,6 +34,7 @@ import Prelude hiding (all) import qualified Control.Lens.Indexed as Lens import qualified Data.Set as S +import Data.List (sort,nub) @@ -281,62 +282,14 @@ epsFree :: Symb -> Symb -> Bool epsFree = undefined -{- - --- | - -data NTSym where - TSym :: [String] -> NTSym - NSym :: [(String, Enumerable)] -> NTSym - deriving (Eq,Ord,Show) - --- | Grammar indices are enumerable objects --- --- TODO should we always assume operations "modulo"? - -data Enumerable - = Singular - | IntBased Integer [Integer] - | Enumerated String [String] - deriving (Eq,Ord,Show) - -instance Default Enumerable where - def = Singular - --- | - -data Grammar = Grammar - { _tsyms :: Set NTSym - , _nsyms :: Set NTSym - , _productions :: Set Production - , _start :: NTSym - } deriving (Show) - -makeLenses ''Grammar - --- | Construct regular grammar. - -regular :: Set NTSym -> Set NTSym -> Set Production -> NTSym -> Grammar -regular = error "regular: not implemented" - -nsym1 :: String -> Enumerable -> NTSym -nsym1 s e = NSym [(s,e)] - -isN (NSym _) = True -isN _ = False - -isT (TSym _) = True -isT _ = False - --- | The size of a grammar. - -size :: Grammar -> Int -size = error "size" +-- | Collect all non-terminal symbols from the rules --- | Transform a grammar into 2NF. +collectSymbN :: Grammar -> [Symb] +collectSymbN g = nub . sort . filter isSymbN $ (g^..rules.folded.lhs) ++ (g^..rules.folded.rhs.folded) -twonf :: Grammar -> Grammar -twonf = error "twonf" +-- | Collect all terminal symbols from the rules (for cfg's it's not really +-- needed to include the lhs). --} +collectSymbT :: Grammar -> [Symb] +collectSymbT g = nub . sort . filter isSymbT $ (g^..rules.folded.lhs) ++ (g^..rules.folded.rhs.folded) diff --git a/FormalLanguage/CFG/TH.hs b/FormalLanguage/CFG/TH.hs --- a/FormalLanguage/CFG/TH.hs +++ b/FormalLanguage/CFG/TH.hs @@ -1,120 +1,219 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternGuards #-} +-- | +-- +-- TODO we should check if it is possible to go a bit ``lower'' to the more raw +-- stuff, instead of trying to rebuild the top-level ADPfusion syntax. Thats +-- mostly for the RHS of rules. +-- +-- TODO we should build the algebra product automatically (but that piece of TH +-- should go into ADPfusion) + module FormalLanguage.CFG.TH where -import Control.Lens hiding (Strict) -import Data.List (intersperse,nub,nubBy,groupBy) -import Language.Haskell.TH -import Data.Vector.Fusion.Stream.Monadic (Stream) -import Control.Arrow -import Control.Applicative -import Control.Monad +import Data.Char (toUpper,toLower) +import Control.Applicative +import Control.Arrow ((&&&)) +import Control.Lens hiding (Strict) +import Control.Monad +import Control.Monad.Trans.Class +import Data.Array.Repa.Index +import Data.Function (on) +import Data.List (intersperse,nub,nubBy,groupBy) +import Data.Maybe +import Data.Vector.Fusion.Stream.Monadic (Stream) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import qualified Data.Map as M import qualified Data.Set as S -import Data.Function (on) -import Control.Monad.Trans.Class -import Data.Maybe +import ADP.Fusion ( (%), (|||), (...), (<<<) ) +import qualified ADP.Fusion.Multi as ADP + import FormalLanguage.CFG.Grammar --- | Given a grammar, create the Signature of data type --- --- @data Signature a b = Signature { ...}@ --- --- TODO we assume that all signature functions have same arity and type; a --- function to check this is currently missing and needs to be added! --- --- TODO need varnames for all NTs and Ts --- --- TODO allow only one type of NTs (as in one type ctor) --- --- TODO need monad vartype also (for opt) +-- * Local data ctors we use to build up signature and grammar -genSignature :: Grammar -> Q Dec -genSignature g = do - let ts = map (PlainTV . mkName . ("t"++)) $ g^..tsyms.folded.symb.folded.tnName - let ns = map (PlainTV . mkName . genNname) $ g^..nsyms.folded -- PlainTV (mkName "xX") - let ns = map (PlainTV . mkName) ["_m", "_x", "_r"] - let fs = map genFname . nub $ g^..rules.folded - let h = genObjectiveFun - s <- dataD (cxt []) (mkName "Signature") (ns++ts) [recC (mkName "Signature") (fs++[h])] [] - return s +data TheTT = TheTT + { _ttType :: TyVarBndr + , _ttName :: Name + , _ttPat :: Pat + } + deriving (Show) --- | Generate the grammar. +makeLenses ''TheTT -genGrammar :: Grammar -> Q Dec -genGrammar g = do - ns <- mapM (\n -> newName (genNname n) >>= \z -> return (n,z)) $ g^..nsyms.folded - ts <- mapM (\t -> newName t >>= \z -> return (t,z)) $ g^..tsyms.folded.symb.folded.tnName - runIO $ print ts - let bd = normalB $ tupE $ map (genPair ns ts) $ groupBy ((==) `on` _lhs) $ S.toList $ g^.rules - f <- funD (mkName "grammar") [clause (map varP $ map snd ns ++ map snd ts) bd [{-decQs-}]] - return f +data TheF = TheF + { _fName :: Name + , _fVar :: Exp + , _fStrict :: Strict + , _fType :: Type + } + deriving (Show) --- | +makeLenses ''TheF -genPair :: [(Symb,Name)] -> [(String,Name)] -> [Rule] -> ExpQ -genPair ns ts rs = do - let l = fromJust $ lookup (head rs ^. lhs) ns - tupE [varE l, tupE []] +fVarStrictType :: Lens' TheF VarStrictType +fVarStrictType = lens get set where + get :: TheF -> VarStrictType + get f = (f^.fName, f^.fStrict, f^.fType) + set :: TheF -> VarStrictType -> TheF + set f (v,s,t) = f { _fName = v, _fStrict = s, _fType = t } --- | +data TheN = TheN + { _nName :: Name + , _nVar :: Exp + , _nPat :: Pat + } + deriving (Show) -genTname = PlainTV . mkName . ("t"++) +makeLenses ''TheN --- | Generate a non-terminal name. Can be used for the type ctor as well as for --- the functions and grammar. +data TheT = TheT + { _tNames :: [Name] + , _tVar :: Exp + , _tType :: Type + } + deriving (Show) -genNname :: Symb -> String -genNname s = ("n_"++) . concat . intersperse "_" $ s^..symb.folded.tnName +makeLenses ''TheT --- | Terminal names are composites either of @t@ or of @(Z:.t1:.t2:. ...)@. The --- correct version is created here. We can not use this for the type ctor. +data TheS = TheS + { _sString :: String + , _sName :: Name + , _sVarP :: Pat + , _sConT :: Type + } -genTType :: Symb -> Type -genTType s - | [z] <- s^.symb = VarT . mkName $ "t"++ z^.tnName - | zs <- s^.symb = foldl - (\l r -> AppT (AppT (ConT . mkName $ ":.") l) r) - (ConT . mkName $ "Z") - (map (VarT . mkName . ("t"++)) $ (zs^..folded.tnName)) +makeLenses ''TheS --- | --- --- TODO the return type is the type of the LHS --- ( AppT ( AppT ArrowT (VarT a_7) ) --- ( AppT ( AppT ArrowT (VarT b_8) ) --- ( VarT c_9 ) --- ) --- ) -genFname :: Rule -> Q (Name,Strict,Type) -genFname r = do - let name = ("f_"++) . concat . intersperse "_" $ r^.fun - let rtrn = VarT . mkName $ "_x" -- . genNname $ r^.lhs - let args = map (AppT ArrowT . genArg) $ r^.rhs - return (mkName name, NotStrict, foldr AppT rtrn args) +-- * Builder functions --- | +-- | Build the signature type and data constructor -genObjectiveFun :: Q (Name,Strict,Type) -genObjectiveFun = do - let name = "h" - let mnd = VarT . mkName $ "_m" - let rtrn = AppT mnd $ VarT . mkName $ "_r" - let strm = ConT . mkName $ "Stream" - let args = AppT ArrowT . AppT (AppT strm mnd) . VarT . mkName $ "_x" - return (mkName name, NotStrict, AppT args rtrn) +genTheS s = do + let n = "Sig" ++ s + return $ TheS n (mkName n) (VarP . mkName . headLower $ n) (ConT . mkName $ n) --- | Create the correct argument. --- --- TODO make sure to handle multi-dim terms using Z:. +-- | the new generator -genArg :: Symb -> Type -genArg s - | isSymbT s = genTType s - | isSymbN s = VarT . mkName $ "_x" -- . genNname $ s +newGen :: Grammar -> Q [Dec] +newGen g = do + m <- newName "m" + x <- newName "x" + r <- newName "r" + ix <- newName "ix" + ns <- M.fromList <$> (mapM genN $ collectSymbN g) + tt <- M.fromList <$> (mapM genTT . nub $ g^..tsyms.folded.symb.folded.tnName) + ts <- M.fromList <$> (mapM (genT tt) $ collectSymbT g) + fs <- M.fromList <$> (mapM (genF x ts) . nubBy ((==) `on` _fun) $ g^..rules.folded) + h <- genHfun m x r + sg <- genTheS $ g^.name + runIO $ print fs + sig <- dataD (cxt []) + (sg^.sName) + (PlainTV m:PlainTV x:PlainTV r:(tt^..folded.ttType)) + [recC (sg^.sName) ((map return $ fs^..folded.fVarStrictType) ++ [return h]) + ] + [] + let graArgs = (recP (sg^.sName) ((return (h^._1, VarP $ h^._1)):[return (n, VarP n) | n <- fs^..folded.fName])) + : (map (return . view nPat) $ ns^..folded) + ++ (map (return . view ttPat) $ tt^..folded) + let graBody = normalB . tupE . map (genBodyPair h ix ns ts fs) . groupBy ((==)`on`_lhs) $ g^..rules.folded + gra <- funD (mkName $ "g" ++ g^.name) [clause graArgs graBody []] + inl <- pragInlD (mkName $ "g" ++ g^.name) Inline FunLike AllPhases + return [sig,gra,inl] + +-- | The body is a series of pairs, built here + +genBodyPair h ix ns ts fs rs = do + let r = head rs + let rhs = lamE [varP ix] + $ appE ( uInfixE (foldl1 (\acc z -> uInfixE acc (varE '(|||)) z) . map (genBodyRhs ns ts fs) $ rs) + (varE '(...)) + (varE $ h^._1) ) + (varE ix) + tupE [return . view nVar $ ns M.! (r^.lhs), rhs] + +-- | the right-hand sides involved in each rule + +genBodyRhs ns ts fs (Rule _ f rs) = appE (appE (varE '(<<<)) (return . view fVar $ fs M.! f)) + . foldl1 (\acc z -> uInfixE acc (varE '(%)) z) . map genS $ rs + where genS s + | isSymbT s = return . view tVar $ ts M.! s + | isSymbN s = return . view nVar $ ns M.! s + +-- | the objective function @h@ is always of the same type, we need to make +-- sure that stream payload and return here are different for things like +-- classified DP. + +genHfun :: Name -> Name -> Name -> Q VarStrictType +genHfun m x r = do + let n = "h" + let strm = ConT ''Stream + let args = AppT ArrowT . AppT (AppT strm (VarT m)) $ VarT x + let rtrn = AppT (VarT m) (VarT r) + return (mkName n, NotStrict, AppT args rtrn) + +-- | Generate all the information for single terminals + +genTT :: String -> Q (String,TheTT) +genTT t = do + nn <- newName t + return (t, TheTT (PlainTV nn) nn (VarP nn)) + +-- | Generate all the function information. Note that we do not create a new +-- name here, because users need to be able to easily identify all the +-- signature functions. + +genF :: Name -> M.Map Symb TheT -> Rule -> Q ([String],TheF) +genF tyN theT r = do + let nn = mkName . headLower . concat . map headUpper $ r^.fun + let args = map (AppT ArrowT . genFArg tyN theT) $ r^.rhs + return (r^.fun, TheF nn (VarE nn) NotStrict (foldr AppT (VarT tyN) args)) + +-- | builds up a function argument + +genFArg :: Name -> M.Map Symb TheT -> Symb -> Type +genFArg tyN theT s + | isSymbT s = view tType $ theT M.! s + | isSymbN s = VarT tyN | otherwise = error $ "incompatible symbol: " ++ show s + +-- | associate each non-terminal with a new name for the variable in the grammar + +genN :: Symb -> Q (Symb,TheN) +genN s = do + nn <- newName "n" + return (s, TheN nn (VarE nn) (VarP nn)) + +-- | builds up a terminal symbol, in 1-dim stuff we just have the terminal +-- symbol; in multi-dim cases we build up using ADPfusion stuff. + +genT :: M.Map String TheTT -> Symb -> Q (Symb,TheT) +genT tt s@(Symb [z]) = do + let n = view ttName $ tt M.! (z^.tnName) + return $ (s, TheT [n] (VarE n) (VarT n)) +genT tt s@(Symb zs) = do + let ns = map (view ttName . (tt M.!) . view tnName) zs + k <- foldl (\acc z -> uInfixE acc (varE '(ADP.:!)) z) (varE 'T) . map varE $ ns + let t = foldl (\l r -> AppT (AppT (ConT '(:.)) l) r) (ConT 'Z) (map VarT ns) + return $ (s, TheT ns k t) + + + +-- * helper functions + +headUpper [] = [] +headUpper (x:xs) = toUpper x : xs + +headLower [] = [] +headLower (x:xs) = toLower x : xs diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,9 @@ +0.0.0.2 +------- + +Cleaned up the TH generator. Should be easier now to build more complex +auto-generators + 0.0.0.1 -------