diff --git a/FormalGrammars.cabal b/FormalGrammars.cabal --- a/FormalGrammars.cabal +++ b/FormalGrammars.cabal @@ -1,7 +1,7 @@ name: FormalGrammars -version: 0.2.1.1 -author: Christian Hoener zu Siederdissen, 2013-2015 -copyright: Christian Hoener zu Siederdissen, 2013-2015 +version: 0.3.0.0 +author: Christian Hoener zu Siederdissen, 2013-2016 +copyright: Christian Hoener zu Siederdissen, 2013-2016 homepage: https://github.com/choener/FormalGrammars bug-reports: https://github.com/choener/FormalGrammars/issues maintainer: choener@bioinf.uni-leipzig.de @@ -11,7 +11,7 @@ build-type: Simple stability: experimental cabal-version: >= 1.10.0 -tested-with: GHC == 7.8.4, GHC == 7.10.2 +tested-with: GHC == 7.8.4, GHC == 7.10.3 synopsis: (Context-free) grammars in formal language theory description: @@ -69,7 +69,7 @@ library build-depends: base >= 4.7 && < 4.9 - , ADPfusion >= 0.4.1 && < 0.5.1 + , ADPfusion >= 0.5.1 && < 0.5.2 , ansi-wl-pprint >= 0.6.7 && < 0.6.8 , bytestring >= 0.10 && < 0.11 , containers @@ -79,7 +79,7 @@ , mtl >= 2.0 && < 3.0 , parsers >= 0.12 && < 0.13 , PrimitiveArray >= 0.6.0 && < 0.7.1 - , semigroups >= 0.16 && < 0.17 + , semigroups >= 0.16 && < 0.19 , template-haskell , text >= 1.0 && < 1.3 , transformers >= 0.3 && < 0.5 @@ -103,7 +103,8 @@ FormalLanguage.CFG.TH default-language: Haskell2010 - default-extensions: DeriveDataTypeable + default-extensions: BangPatterns + , DeriveDataTypeable , DataKinds , FlexibleContexts , FlexibleInstances diff --git a/FormalLanguage/CFG/TH.hs b/FormalLanguage/CFG/TH.hs --- a/FormalLanguage/CFG/TH.hs +++ b/FormalLanguage/CFG/TH.hs @@ -78,7 +78,7 @@ , _qFullSyntVarNames :: M.Map Symbol Name -- ^ type variable names for the fully applied grammar body / where part -- everything on terminals , _qTermAtomVarNames :: M.Map (String,Int) Name -- ^ (Term-id,Dimension) to var name - , _qTermAtomTyNames :: M.Map String Name -- ^ the type name for each unique terminal symbol (that is: the scalar terminals in each dimension) + , _qTermAtomTyNames :: M.Map (String,Int) Name -- ^ the type name for each unique terminal symbol (that is: the scalar terminals in each dimension) , _qTermSymbExp :: M.Map Symbol (Type,Exp) -- ^ associate a terminal @Symb@ with a complete @Type@ and @Exp@ , _qPrefix :: String -- ^ prefix for attribute functions } @@ -123,7 +123,7 @@ _qMTyName <- newName "m" _qElemTyName <- newName "s" _qRetTyName <- newName "r" - _qTermAtomTyNames <- M.fromList <$> (mapM (\t -> (t,) <$> newName ("t_" ++ t)) $ g^..termvars.folded.name.getSteName) + _qTermAtomTyNames <- M.fromList <$> (mapM (\(name,tape) -> ((name,tape),) <$> newNameTerm "t" name tape) $ terminalsWithTape g) -- 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) @@ -307,16 +307,14 @@ elemTyName <- use qElemTyName synNames <- use qFullSyntVarNames -- just the name of the fully applied symbol g <- use qGrammar - let genType :: [SynTermEps] -> TypeQ - genType z --- | Symb Outside _ <- z = error $ printf "terminal symbol %s with OUTSIDE annotation!\n" (show z) + let genType :: Int -> [SynTermEps] -> TypeQ + genType tape z | [Deletion] <- z = [t| () |] | [Epsilon ] <- z = [t| () |] | [Term tnm tidx] <- z - , Just v <- M.lookup (tnm^.getSteName) ttypes = varT v - | [Term tnm tidx] <- z - {- , Just v <- M.lookup (tnm^.getSteName) (error "bla") -} = varT elemTyName - | xs <- z = foldl (\acc z -> [t| $acc :. $(genType [z]) |]) [t| Z |] xs + , Just v <- M.lookup (tnm^.getSteName,tape) ttypes = varT v -- single dimension only, set dim to 0 + | [Term tnm tidx] <- z = varT elemTyName + | xs <- z = foldl (\acc (tape',z) -> [t| $acc :. $(genType tape' [z]) |]) [t| Z |] (zip [0..] xs) let genSingleExp :: Int -> SynTermEps -> ExpQ genSingleExp _ Deletion = [| ADP.Deletion |] genSingleExp _ Epsilon = [| ADP.Epsilon |] @@ -325,28 +323,29 @@ | Just n <- M.lookup (tnm^.getSteName,k) tavn = varE n -- TODO this one is dangerous but currently necessary for split -- systems - | Just n <- M.lookup (tnm^.getSteName,0) tavn = varE n + | Just n <- M.lookup (tnm^.getSteName,k) tavn = varE n | otherwise = error $ show ("genSingleExp:Term: ",k,tnm,tidx, tavn) genSingleExp _ err = error $ "genSingleExp: " ++ show (s,err) let genExp :: [SynTermEps] -> ExpQ genExp z --- | Symb Outside _ <- z = error $ printf "terminal symbol %s with OUTSIDE annotation!\n" (show z) | [Deletion] <- z = [| ADP.Deletion |] -- TODO ??? | [Epsilon ] <- z = [| ADP.Epsilon |] | [Term tnm tidx] <- z , Just v <- M.lookup (tnm^.getSteName,0) tavn = varE v | xs <- z = foldl (\acc (k,z) -> [| $acc ADP.:| $(genSingleExp k z) |]) [| ADP.M |] $ zip [0..] xs -{- - | xs <- z = foldl (\acc (k,z) -> [| $acc ADP.:| $(case z of { Deletion -> [| ADP.Deletion |] - ; Epsilon -> [| ADP.Epsilon |] - ; Term tnm tidx -> varE $ M.findWithDefault (error $ "genExp: " ++ show (tnm^.getSteName,k)) (tnm^.getSteName,k) tavn - }) |]) - [| ADP.M |] $ zip [0..] xs -} - ty <- lift . genType $ s^.getSymbolList + ty <- lift . genType 0 $ s^.getSymbolList ex <- lift . genExp $ s^.getSymbolList return (s, (ty,ex)) +-- | Given a grammar, gives us each terminal on each tape. + +terminalsWithTape :: Grammar -> [(String,Int)] +terminalsWithTape = map go . filter isTerm . uniqueTermsWithTape -- uniqueBindableTermsWithTape + where go (t,d) = (t^.name.getSteName,d^.getTape) + isTerm (Term{},_) = True + isTerm _ = False + -- | Each terminal symbol is bound to some input. Since we might have the -- same name in different dimensions, we now explicitly annotate with -- a dimensional index. This means that each atomic terminal is annotated @@ -355,11 +354,12 @@ 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) + ys <- forM (terminalsWithTape g) $ \(name,tape) -> do + ( (name,tape) , ) <$> (lift $ newNameTerm "term" name tape) return ys + +--newNameTerm :: String -> Int -> TQ Name +newNameTerm prefix name tape = newName $ prefix ++ "_" ++ name ++ "_" ++ show tape ++ "_" -- | Build the full grammar. Generate a name (the grammar name prefixed -- with a @"g"@), the arguments, and the body of the grammar. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,13 @@ +0.3.0.0 +------- + +- Major change in terminal symbol handling: In 0.2.x.y versions, when you named + a terminal (say 'c') then each occurance of 'c' had the same type. This was + *independent* of the tape the symbol occured on. Starting with 0.3.0.0 if you + have a terminal with the same name on different tapes, then you will have to + give each type explicitly. This requires a bit more typing for homogenous + grammars, but makes heterogenous multi-tape grammars much more flexible. + 0.2.1.0 ------- diff --git a/src/NeedlemanWunsch.hs b/src/NeedlemanWunsch.hs --- a/src/NeedlemanWunsch.hs +++ b/src/NeedlemanWunsch.hs @@ -12,7 +12,6 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax import qualified Data.Vector.Fusion.Stream.Monadic as SM -import qualified Data.Vector.Fusion.Stream as S import qualified Data.Vector.Unboxed as VU import Data.Vector.Unboxed (Vector) import Text.Printf @@ -31,13 +30,12 @@ Grammar: Global N: X -T: l -T: u +T: c -- NOTE that each tape with a 'c' uses its own type! S: [X,X] [X,X] -> done <<< [e,e] -[X,X] -> align <<< [X,X] [l,u] -[X,X] -> indel <<< [X,X] [-,u] -[X,X] -> delin <<< [X,X] [l,-] +[X,X] -> align <<< [X,X] [c,c] +[X,X] -> indel <<< [X,X] [-,c] +[X,X] -> delin <<< [X,X] [c,-] // Emit: Global @@ -46,6 +44,7 @@ makeAlgebraProduct ''SigGlobal + -- | score :: Monad m => SigGlobal m Int Int Char Char @@ -58,6 +57,7 @@ } {-# INLINE score #-} + -- | -- -- NOTE The alignment needs to be reversed to print out. @@ -83,7 +83,7 @@ -- | Decoupling the forward phase for CORE observation. -runNeedlemanWunschForward :: Vector Char -> Vector Char -> Z:.(ITbl Id Unboxed (Z:.PointL:.PointL) Int) +runNeedlemanWunschForward :: Vector Char -> Vector Char -> Z:.(ITbl Id Unboxed (Z:.PointL I:.PointL I) Int) runNeedlemanWunschForward i1 i2 = let n1 = VU.length i1; n2 = VU.length i2 in mutateTablesDefault $ gGlobal score (ITbl 0 0 (Z:.EmptyOk:.EmptyOk) (PA.fromAssocs (Z:.PointL 0:.PointL 0) (Z:.PointL n1:.PointL n2) (-999999) [])) diff --git a/src/Nussinov.hs b/src/Nussinov.hs --- a/src/Nussinov.hs +++ b/src/Nussinov.hs @@ -11,7 +11,6 @@ import Data.Vector.Fusion.Util import Language.Haskell.TH import Language.Haskell.TH.Syntax -import qualified Data.Vector.Fusion.Stream as S import qualified Data.Vector.Fusion.Stream.Monadic as SM import qualified Data.Vector.Unboxed as VU import Text.Printf @@ -92,7 +91,7 @@ $ gNussinov bpmax (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) (chr i) - :: Z:.ITbl Id Unboxed Subword Int + :: Z:.ITbl Id Unboxed (Subword I) Int d = unId $ axiom t !(Z:.b) = gNussinov (bpmax <|| pretty) (toBacktrack t (undefined :: Id a -> Id a)) (chr i) {-# NoInline runNussinov #-} @@ -103,10 +102,10 @@ n = VU.length i !(Z:.t) = mutateTablesDefault $ gVonissun bpmaxV - (ITbl 0 0 EmptyOk (PA.fromAssocs (O $ subword 0 0) (O $ subword 0 n) (-999999) [])) - (undefined :: ITbl Id Unboxed Subword Int) + (ITbl 0 0 EmptyOk (PA.fromAssocs (subword 0 0) (subword 0 n) (-999999) [])) + (undefined :: ITbl Id Unboxed (Subword O) Int) (chr i) - :: Z:.ITbl Id Unboxed (Outside Subword) Int + :: Z:.ITbl Id Unboxed (Subword O) Int d = unId $ axiom t -- !(Z:.b) = gVonissun (bpmaxV <|| prettyV) (toBacktrack t (undefined :: Id a -> Id a)) (undefined :: Backtrack (ITbl Id Unboxed Subword Int) Id Id String) (chr i) {-# NoInline runVonissun #-}