FormalGrammars 0.0.0.1 → 0.0.0.2
raw patch · 4 files changed
+204/−146 lines, 4 files
Files
- FormalGrammars.cabal +1/−1
- FormalLanguage/CFG/Grammar.hs +8/−55
- FormalLanguage/CFG/TH.hs +189/−90
- changelog +6/−0
FormalGrammars.cabal view
@@ -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/
FormalLanguage/CFG/Grammar.hs view
@@ -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)
FormalLanguage/CFG/TH.hs view
@@ -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
changelog view
@@ -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 -------