NaturalLanguageAlphabets 0.1.1.0 → 0.2.1.0

raw patch · 15 files changed

+673/−268 lines, 15 filesdep +InternedDatadep +ansi-wl-pprintdep +bytestringdep −LinguisticsTypesdep −attoparsecdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: InternedData, ansi-wl-pprint, bytestring, errors, hashable, lens, mtl, parsers, tasty-hunit, transformers, trifecta, utf8-string

Dependencies removed: LinguisticsTypes, attoparsec

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• NLP/Scoring/SimpleUnigram.hs +0/−62
• NLP/Scoring/SimpleUnigram/Default.hs +0/−16
• NLP/Scoring/SimpleUnigram/Import.hs +0/−107
• NLP/Scoring/Unigram.hs +112/−0
• NLP/Scoring/Unigram/Default.hs +18/−0
• NLP/Scoring/Unigram/Import.hs +283/−0
• NaturalLanguageAlphabets.cabal +36/−14
• changelog.md +12/−0
• scoring/simpleunigram.score +0/−45
• scoring/unigramdefault.score +85/−0
• scoring/unigramnancy.score +64/−0
• tests/Benchmark.hs +9/−9
• tests/properties.hs +40/−15
• tests/uni01.score +6/−0
• tests/uni02.score +8/−0

@@ -1,62 +0,0 @@---- | This module defines a simple scoring scheme based on pairs of unigrams.--module NLP.Scoring.SimpleUnigram where--import GHC.Generics-import Data.HashMap.Strict-import Data.Aeson--import NLP.Text.BTI------ | Score 'BTI's @x@ and @y@ based on the simple scoring system: (i)--- lookup (x,y) and use the score if found; (ii) if (x,y) is not in the--- database, then return the default matching 'defMatch' score if @x==y@,--- otherwise return the default mismatch 'defMismatch' score.--scoreUnigram :: SimpleScoring -> BTI -> BTI -> Double-scoreUnigram SimpleScoring {..} x y =-  lookupDefault (if x==y then defMatch else defMismatch) (x,y) simpleScore-{-# INLINE scoreUnigram #-}---- | Collect the hashtable and scalar values for simple scoring.------ TODO binary and cereal instances--data SimpleScoring = SimpleScoring-  { simpleScore   :: !(HashMap (BTI,BTI) Double)-  , gapScore      :: !Double-  , gapOpen       :: !Double-  , gapExt        :: !Double-  , defMatch      :: !Double-  , defMismatch   :: !Double-  , preSufOpen    :: !Double-  , preSufExt     :: !Double-  }-  deriving (Read,Show,Eq,Generic)--instance FromJSON SimpleScoring where-  parseJSON (Object v) = SimpleScoring <$>-                          (fromList `fmap` (v .: "simpleScore")) <*>-                          v .: "gapScore"    <*>-                          v .: "gapOpen"     <*>-                          v .: "gapExt"      <*>-                          v .: "defMatch"    <*>-                          v .: "defMismatch" <*>-                          v .: "preSufOpen"  <*>-                          v .: "preSufExt"--instance ToJSON SimpleScoring where-  toJSON SimpleScoring {..}-    = object [ "simpleScore" .= toList simpleScore-             , "gapScore"    .= gapScore-             , "gapOpen"     .= gapOpen-             , "gapExt"      .= gapExt-             , "defMatch"    .= defMatch-             , "defMismatch" .= defMismatch-             , "preSufOpen"  .= preSufOpen-             , "preSufExt"   .= preSufExt-             ]-

@@ -1,16 +0,0 @@--module NLP.Scoring.SimpleUnigram.Default where--import Data.FileEmbed (embedFile)-import Data.Text.Encoding (decodeUtf8)--import NLP.Scoring.SimpleUnigram-import NLP.Scoring.SimpleUnigram.Import------ | Default simple unigram scores for a system of consonants, liquid--- consonants, and vowels of arbitrary scale.--clvDefaults = genSimpleScoring $ decodeUtf8 $(embedFile "scoring/simpleunigram.score")-

@@ -1,107 +0,0 @@--module NLP.Scoring.SimpleUnigram.Import where--import           Control.Applicative-import           Data.HashMap.Strict (fromList)-import           Data.Text (Text)-import qualified Data.Attoparsec.Text as AT-import qualified Data.Text as T-import qualified Data.Text.IO as T-import           Data.Attoparsec.Text ((<?>))--import           NLP.Text.BTI--import           NLP.Scoring.SimpleUnigram------ | Each parsed line gives a set of characters, or tells us a score.------ TODO add @LPimport@ which starts a recursive import (note: start by storing--- the hash or whatever of the file to be imported so that we can comment on--- circular imports)--data ParsedLine-  = PLset Text [BTI]-  | PLeq Text Double-  | PLeqset Text [BTI]-  | PLinset Text Text Double-  | PLgap Double-  | PLgapopen Double-  | PLgapextend Double-  | PLdefmatch Double-  | PLdefmismatch Double-  | PLpresufOpen Double-  | PLpresufExt Double-  | PLcomment Text-  deriving (Show,Eq,Ord)---- | Here we simple parse individual lines.--parseLine :: Text -> ParsedLine-parseLine l = case AT.parseOnly (go <* AT.endOfInput) l of-                Left  err -> error $ err ++ " " ++ show l-                Right p   -> p-  where go =   PLset         <$ "Set"           <*> wd <*> mc `AT.sepBy1` AT.skipSpace -- AB.skipWhile AB.isHorizontalSpace-           <|> PLeq          <$ "Eq"            <*> wd <*> nm-           <|> PLinset       <$ "InSet"         <*> wd <*> wd <*> nm-           <|> (PLgap         <$ "Gap"           <*> nm  <?> "(linear) Gap")-           <|> (PLgapopen     <$ "GapOpen"       <*> nm  <?> "GapOpen")-           <|> (PLgapextend   <$ "GapExtend"     <*> nm  <?> "GapExtend")-           <|> (PLdefmatch    <$ "Match"         <*> nm  <?> "Match")-           <|> (PLdefmismatch <$ "Mismatch"      <*> nm  <?> "Mismatch")-           <|> (PLpresufOpen  <$ "PreSufOpen"    <*> nm  <?> "PreSufOpen")-           <|> (PLpresufExt   <$ "PreSufExtend"  <*> nm  <?> "PreSufExtend")-           <|> PLeqset       <$ "EqSet"         <*> wd <*> mc `AT.sepBy1` AT.skipSpace-           <|> PLcomment     <$ "--"            <*> AT.takeText-        wd = AT.skipSpace *> AT.takeWhile1 (not . AT.isHorizontalSpace)-        mc = bti <$> wd-        nm = AT.skipSpace *> AT.double---- | Parses a bytestring to create a simple scoring. We don't do much error--- checking, many of the bindings below will easily fail.------ TODO obviously: implement error-checking--genSimpleScoring :: Text -> SimpleScoring-genSimpleScoring l = SimpleScoring{..} -- SimpleScoring t g go ge dm di-  where-    simpleScore = fromList ys-    [defMatch]    = [dm | PLdefmatch dm     <- xs]-    [defMismatch] = [di | PLdefmismatch di  <- xs]-    [gapScore]    = [g  | PLgap g           <- xs]-    [gapOpen]     = [go | PLgapopen go      <- xs]-    [gapExt]      = [ge | PLgapextend ge    <- xs]-    [preSufOpen]  = [ps | PLpresufOpen ps   <- xs]-    [preSufExt]   = [ps | PLpresufExt ps    <- xs]-    ls   = T.lines l-    xs   = map parseLine ls-    ys   = concatMap genPairs $ iss ++ eqs-    sets = [s  | s@(PLset _ _)     <- xs]-    eqss = [e  | e@(PLeqset _ _)   <- xs]-    eqs  = [e  | e@(PLeq _ _)      <- xs]-    iss  = [i  | i@(PLinset _ _ _) <- xs]-    -- this generates all "equality pairs", i.e. that 'a' == 'a'-    -- the second list generates all equivalence classes, say that 'a' == 'ã'-    genPairs (PLeq    x   d) = let ss = lookupSet x-                                   tt = lookupEqSet x-                               in  [ ((s,s),d) | s <- ss ] ++-                                   [ ((s,t),d) | ts <- tt, s<-ts,t<-ts ]-    -- this creates all variants of, say, vowel against vowel (but unequal)-    genPairs (PLinset x y d) = let ss = lookupSet x-                                   tt = lookupSet y in [ ((s,t),d) | s <- ss, t <- tt ]-    -- find every character from an equivalence set-    lookupEqSet k = let go [] = []-                        go (PLeqset n xs:ss) = if k==n then xs : go ss else go ss-                    in  go eqss-    -- find every character from a certain class-    lookupSet k = let go [] = []-                      go (PLset n xs:ss) = if k==n then xs : go ss else go ss-                      go (PLeqset n xs:ss) = if k==n then xs : go ss else go ss-                  in  case go $ sets ++ eqss of-                        xs -> concat xs---- | parse a simple scoring file.--simpleScoreFromFile f = T.readFile f >>= return . genSimpleScoring-

@@ -0,0 +1,112 @@++-- | This module defines a simple scoring scheme based on pairs of unigrams.++module NLP.Scoring.Unigram where++import Data.Aeson+import Data.Hashable+import Data.HashMap.Strict+import GHC.Generics++import Data.ByteString.Interned++++-- | Score 'IBS's @x@ and @y@ based on the simple scoring system: (i)+-- lookup (x,y) and use the score if found; (ii) if (x,y) is not in the+-- database, then return the default matching 'defaultMatch' score if+-- @x==y@, otherwise return the default mismatch 'defaultMismatch' score.+-- Note that even though @IBS k@ and @IBS l@ have different types,+-- mismatches are checked using the underlying @Int@ representation.++matchUnigram ∷ UnigramScoring k l → IBS k → IBS l → Double+matchUnigram UnigramScoring{..} x y =+  lookupDefault (if getIBS x == getIBS y then usDefaultMatch else usDefaultMismatch) (x,y) usUnigramMatch+{-# Inline matchUnigram #-}++-- | Provides a score for the unigram characters in an @in/del@+-- environment. In case the character @x@ in the pairing @x == '-'@ is+-- found in the @unigramInsert@ database, that score is used, otherwise the+-- @gapLinear@ score is used.++insertUnigramFstK ∷ UnigramScoring k l → IBS k → Double+insertUnigramFstK UnigramScoring{..} x =+  lookupDefault usGapLinear x usUnigramInsertFstK+{-# Inline insertUnigramFstK #-}++-- | Analog to 'insertUnigramSndL', but works on the @IBS l@ with phantom+-- type @l@.++insertUnigramSndL ∷ UnigramScoring k l → IBS l → Double+insertUnigramSndL UnigramScoring{..} x =+  lookupDefault usGapLinear x usUnigramInsertSndL+{-# Inline insertUnigramSndL #-}++-- TODO $UTF-Vowels , etc in parsing ?!++-- | Collect the hashtable and scalar values for simple scoring.+--+-- TODO binary and cereal instances++data UnigramScoring k l = UnigramScoring+  { usUnigramMatch          ∷ !(HashMap (IBS k, IBS l) Double)+  -- ^ All known matching characters and associated scores.+  , usUnigramInsertFstK     ∷ !(HashMap (IBS k) Double)+  -- ^ Characters that can be deleted with costs different from+  -- @gapOpen@/@gapExtension@. This is the insertion map, associated with+  -- the first type @k@.+  , usUnigramInsertSndL     ∷ !(HashMap (IBS l) Double)+  -- ^ Characters that can be deleted with costs different from+  -- @gapOpen@/@gapExtension@. This is the insertion map, associated with+  -- the second type @l@.+  , usGapLinear             ∷ !Double+  -- ^ linear gap scores+  , usGapOpen               ∷ !Double+  -- ^ Gap opening costs for Gotoh-style grammars.+  , usGapExtension          ∷ !Double+  -- ^ Gap extension costs for Gotoh-style grammars.+  , usDefaultMatch          ∷ !Double+  -- ^ Default score for characters matching, i.e. @x==y@.+  , usDefaultMismatch       ∷ !Double+  -- ^ Default score for characters not matching, i.e. @x/=y@.+  , usPrefixSuffixLinear    ∷ !Double+  -- ^ Special gap score for a prefix or suffix.+  , usPrefixSuffixOpen      ∷ !Double+  -- ^ Special gap opening score for a prefix or suffix.+  , usPrefixSuffixExtension ∷ !Double+  -- ^ Special gap extension score for a prefix or suffix.+  }+  deriving (Read,Show,Eq,Generic)++instance Hashable (UnigramScoring k l)++instance FromJSON (UnigramScoring k l) where+  parseJSON (Object v)+    =   UnigramScoring+    <$> (fromList `fmap` (v .: "unigramMatch"))+    <*> (fromList `fmap` (v .: "unigramInsertFstK"))+    <*> (fromList `fmap` (v .: "unigramInsertSndL"))+    <*> v .: "gapLinear"+    <*> v .: "gapOpen"+    <*> v .: "gapExtension"+    <*> v .: "defaultMatch"+    <*> v .: "defaultMismatch"+    <*> v .: "prefixSuffixLinear"+    <*> v .: "prefixSuffixOpen"+    <*> v .: "prefixSuffixExtension"++instance ToJSON (UnigramScoring k l) where+  toJSON UnigramScoring {..}+    = object [ "unigramMatch"           .= toList usUnigramMatch+             , "unigramInsertFstK"      .= toList usUnigramInsertFstK+             , "unigramInsertSndL"      .= toList usUnigramInsertSndL+             , "gapLinear"              .= usGapLinear+             , "gapOpen"                .= usGapOpen+             , "gapExtension"           .= usGapExtension+             , "defaultMatch"           .= usDefaultMatch+             , "defaultMismatch"        .= usDefaultMismatch+             , "prefixSuffixLinear"     .= usPrefixSuffixLinear+             , "prefixSuffixOpen"       .= usPrefixSuffixOpen+             , "prefixSuffixExtension"  .= usPrefixSuffixExtension+             ]+

@@ -0,0 +1,18 @@++module NLP.Scoring.Unigram.Default where++import Data.FileEmbed (embedFile)+import Data.Text.Encoding (decodeUtf8)+import Control.Monad.Except++import NLP.Scoring.Unigram+import NLP.Scoring.Unigram.Import++++-- | Default simple unigram scores for a system of consonants, liquid+-- consonants, and vowels of arbitrary scale.++clvDefaults = either (error . errorToString) id . runExcept+            $ fromByteString $(embedFile "scoring/unigramdefault.score") "scoring/unigramdefault.score"+

@@ -0,0 +1,283 @@++-- |+--+-- TODO normalization of characters! (though it might be better to do this not in the importer, but+-- a normalization function)++module NLP.Scoring.Unigram.Import where++import           Control.Applicative+import           Control.Arrow (first, (***))+import           Control.Lens+import           Control.Monad+import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Control.Monad.State.Class+import           Control.Monad.Trans.State.Strict hiding (gets)+import           Control.Monad.Except+import           Data.ByteString (ByteString)+import           Data.Char+import           Data.HashMap.Strict (fromList, HashMap)+import           Data.HashSet (HashSet)+import           Data.Maybe+import           Data.Monoid+import           Data.String (IsString)+import           Data.Text (Text)+import           Debug.Trace+import qualified Data.ByteString as BS+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Sequence as S+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           System.Exit (exitFailure)+import           System.IO (stdout)+import           Text.Parser.LookAhead+import           Text.Parser.Token.Style+import           Text.PrettyPrint.ANSI.Leijen (displayIO, renderPretty, linebreak, displayS)+import           Text.Trifecta as TT+import           Text.Trifecta.Delta (Delta(..))++import           Data.ByteString.Interned++import           NLP.Scoring.Unigram++++data Env = Env+  { _warnings           ∷ !(S.Seq Text)+  , _defaults           ∷ !(HashMap Text Double)+  , _charGroups         ∷ !(HashMap Text (HashSet Text))+  , _matchScores        ∷ !(HashMap (Text,Text) Double)+  , _ignoredScoresFstK  ∷ !(HashMap Text Double)+  , _ignoredScoresSndL  ∷ !(HashMap Text Double)+  }+  deriving (Show)++makeLenses ''Env++defaultEnv = Env+  { _warnings           = S.empty+  , _defaults           = HM.empty+  , _charGroups         = HM.empty+  , _matchScores        = HM.empty+  , _ignoredScoresFstK  = HM.empty+  , _ignoredScoresSndL  = HM.empty+  }++++test = runExceptT $ fromFile True "scoring/unigramdefault.score"++-- | This will prettyprint the error message and ungracefully exit++prettyErrorAndExit ∷ MonadIO m ⇒ ErrInfo → m ()+prettyErrorAndExit e = do+  liftIO $ displayIO stdout $ renderPretty 0.8 80 $ (_errDoc e) <> linebreak+  liftIO $ exitFailure++-- | Returns the error message, but will not exit.++errorToString :: ErrInfo → String+errorToString e = (displayS . renderPretty 0.8 80 $ _errDoc e) ""++fromByteString ∷ ByteString → String → Except ErrInfo (UnigramScoring k l)+fromByteString s fn = r where+  p = parseByteString (runP $ runStateT pUnigram defaultEnv)+                      (Directed (UTF8.fromString fn) 0 0 0 0) s+  r = case p of+        Success (p',e) → return p'+        Failure e      → throwError e++fromFile ∷ Bool → FilePath → ExceptT ErrInfo IO (UnigramScoring k l)+fromFile warn fp = do+  p' <- TT.parseFromFileEx (runP $ runStateT pUnigram defaultEnv) fp+  case p' of+    Success (p,e) → do+      let ws = e^.warnings+      unless (null ws || not warn) $ do+        liftIO $ mapM_ T.putStrLn ws+      return p+    Failure e → throwError e++pUnigram ∷ UnigramParser (UnigramScoring k l)+pUnigram = do+  whiteSpace+  many $ choice [pDefaults,pCharGroup,pSimilarity,pEquality,pIgnored]+  eof+  let uconstants ∷ Text → UnigramParser Double+      uconstants k = do+        kv ← use defaults+        case HM.lookup k kv of+          Nothing → do+            warnings %= (S.|> ("constant " <> k <> " not found, using default (-999999)"))+            return (-999999)+          Just v  → return v+  usUnigramMatch      ← (HM.fromList . map (first (ibsText *** ibsText)) . HM.toList) <$> use matchScores+  usUnigramInsertFstK ← (HM.fromList . map (first ibsText) . HM.toList) <$> use ignoredScoresFstK+  usUnigramInsertSndL ← (HM.fromList . map (first ibsText) . HM.toList) <$> use ignoredScoresSndL+  usGapLinear     <- uconstants "GapLinear"+  usGapOpen       <- uconstants "GapOpen"+  usGapExtension  <- uconstants "GapExtension"+  usDefaultMatch    <- uconstants "Match"+  usDefaultMismatch <- uconstants "Mismatch"+  usPrefixSuffixLinear    <- uconstants "PrefixSuffixLinear"+  usPrefixSuffixOpen      <- uconstants "PrefixSuffixOpen"+  usPrefixSuffixExtension <- uconstants "PrefixSuffixExtension"+--  -- Given the @Env@, we can now construct the actual scoring system.+  return UnigramScoring{..}++-- | Defaults are key-value pairs, of which there is only a small set.++pDefaults :: UnigramParser ()+pDefaults = choice $ map pConstant cs+  where+    cs = [ "GapLinear", "GapOpen", "GapExtend", "PrefixSuffixOpen", "PrefixSuffixExtend"+         , "Match", "Mismatch"+         ]+    pConstant :: Text -> UnigramParser ()+    pConstant r = do+      reserveText reserved r+      ds <- use defaults+      when (HM.member r ds) (fail $ show r ++ " already defined")+      v <- either fromIntegral id <$> integerOrDouble+      defaults %= HM.insert r v++-- | Gives a name to a set of characters we want to work with later on.++pCharGroup :: UnigramParser ()+pCharGroup = do+  reserve reserved "CharGroup"+  ty <- ident reserved+  -- TODO the {,} guys+  ls <- option [] . braces $ pExpansionOptions `sepEndBy` comma+  vs' <- runUnlined $ do+    gs <- HS.unions <$> (some $ (HS.singleton <$> pGrapheme) <|> pKnownCharGroup)+    rol <- restOfLine+    unless (rol == "\n") $ fail $ show (gs,rol)+    return gs+  someSpace+  let vs = applySpecialFunctions ls vs'+  charGroups %= HM.insert ty vs++-- | Parses a similarity line and updates the scores for the pairs of+-- characters.++pSimilarity :: UnigramParser ()+pSimilarity = do+  reserve reserved "Similarity"+  ls1 <- option [] . braces $ pExpansionOptions `sepEndBy` comma+  ty1 <- runUnlined pKnownCharGroup+  ls2 <- option [] . braces $ pExpansionOptions `sepEndBy` comma+  ty2 <- runUnlined pKnownCharGroup+  v  <- either fromIntegral id <$> integerOrDouble+  let xs = applySpecialFunctions ls1 ty1+  let ys = applySpecialFunctions ls2 ty2+  let vs = HM.fromList [ ((x,y),v) | x <- HS.toList xs, y <- HS.toList ys ]+  -- mapping from the first will be the result in clashes, hence @HS.union+  -- vs old@ ...+  matchScores %= HM.union vs++-- | Parses an equality line and updates the scores for the pairs of+-- characters.++pEquality :: UnigramParser ()+pEquality = do+  reserve reserved "Equality"+  ls <- option [] . braces $ pExpansionOptions `sepEndBy` comma+  ty <- runUnlined pKnownCharGroup+  v  <- either fromIntegral id <$> integerOrDouble+  let xss = map (applySpecialFunctions ls . HS.singleton) $ HS.toList ty+  let vs = HM.fromList [ ((x,y),v) | xs <- xss, x <- HS.toList xs, y <- HS.toList xs ]+  matchScores %= HM.union vs++data FstKSndL = FstK | SndL+  deriving (Eq,Ord)++pIgnored :: UnigramParser ()+pIgnored =   (reserve reserved "Ignored"    >> go [FstK,SndL])+         <|> (reserve reserved "IgnoredFst" >> go [FstK]     )+         <|> (reserve reserved "IgnoredSnd" >> go [     SndL])+  where+    go what = do+      ls <- option [] . braces $ pExpansionOptions `sepEndBy` comma+      ty <- runUnlined pKnownCharGroup+      v  <- either fromIntegral id <$> integerOrDouble+      let xs = applySpecialFunctions ls ty+      let vs = HM.fromList [ (x,v) | x <- HS.toList xs ]+      when (FstK `elem` what) $ ignoredScoresFstK %= HM.union vs+      when (SndL `elem` what) $ ignoredScoresSndL %= HM.union vs++-- | Defines what a grapheme is. Basically, don't be a whitespace and don't+-- start with '$'.+--+-- TODO we probably want to allow \$ to stand for '$'.++pGrapheme :: (CharParsing p, TokenParsing p) => p Text+pGrapheme = (T.pack <$> some (satisfy allowed) <* someSpace) <?> "pGrapheme"+  where allowed x = (not $ isSpace x || x `elem` ("${}" :: String))++-- | Returns the set of characters from a known character group++pKnownCharGroup :: Unlined UnigramParser (HS.HashSet Text)+pKnownCharGroup = go <?> "pKnownCharGroup" where+  go = do+    char '$'+    ty <- ident reserved+    cgs <- use charGroups+    case HM.lookup ty cgs of+      Nothing -> fail $ show ty ++ " is not a known CharGroup!"+      Just cg -> return cg++-- | How we can expand a group with special functions.++pExpansionOptions :: UnigramParser Text+pExpansionOptions = choice $ map (text . fst) specialFunctions++specialFunctions ∷ [(Text, Text → Text)]+specialFunctions =+  [ ("ToUpper", T.toUpper)+  , ("ToLower", T.toLower)+  ]++applySpecialFunctions ls xs =+  HS.unions $ xs : [ HS.map sf xs | (sfn,sf) <- specialFunctions, sfn `elem` ls ]++-- | TODO only insert warning, not error, after seeing a character again!++setIdent :: HashSet Text -> Unlined UnigramParser Text+setIdent e = try $ do+  k <- ident reserved+  when (HS.member k e) $ fail "Character already present in EqualChars!"+  return k++reserved :: TokenParsing m => IdentifierStyle m+reserved = emptyIdents { _styleReserved = rs }+  where rs = HS.fromList [ -- "EqualChars", "SimilarChars", "EqualScore", "SimilarScore"+                         -- , "IgnoredChars", "CharGroup"+                         ]++-- | This is just the trifecta parser, but with haskell-style comments enabled.++newtype P a = P { runP :: Parser a }+  deriving ( Applicative+           , Monad+           , Functor+           , DeltaParsing+           , MonadPlus+           , Alternative+           , CharParsing+           , Parsing+           )++-- | This enables the haskell-style comments.++instance TokenParsing P where+  someSpace = buildSomeSpaceParser+    (skipSome (satisfy isSpace))+    haskellCommentStyle++type UnigramParser = StateT Env P++deriving instance DeltaParsing (Unlined UnigramParser)+

@@ -1,17 +1,17 @@+cabal-version:  2.2 name:           NaturalLanguageAlphabets-version:        0.1.1.0+version:        0.2.1.0 author:         Christian Hoener zu Siederdissen maintainer:     choener@bioinf.uni-leipzig.de homepage:       https://github.com/choener/NaturalLanguageAlphabets bug-reports:    https://github.com/choener/NaturalLanguageAlphabets/issues-copyright:      Christian Hoener zu Siederdissen, 2014-2017+copyright:      Christian Hoener zu Siederdissen, 2014-2019 category:       Natural Language Processing-license:        BSD3+license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple stability:      experimental-cabal-version:  >= 1.10.0-tested-with:    GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1+tested-with:    GHC == 8.6.4 synopsis:       Simple scoring schemes for word alignments description:                 Provides a simple scoring scheme for word alignments.@@ -21,37 +21,56 @@ extra-source-files:   README.md   changelog.md-  scoring/simpleunigram.score+  scoring/unigramdefault.score+  scoring/unigramnancy.score+  tests/uni01.score+  tests/uni02.score    library   build-depends: base                   >  4.7      &&  < 5.0-               , aeson                  >= 0.8-               , attoparsec             >= 0.10+               , aeson                  >= 1.0+               , ansi-wl-pprint         >= 0.6+               , bytestring+               , containers+               , errors                 >= 2.0                , file-embed             >= 0.0.6+               , hashable               >= 1.2.0.0+               , lens                   >= 4.0+               , mtl                    >= 2.0+               , parsers                >= 0.12                , text                   >= 0.11+               , transformers           >= 0.4+               -- last version to use ansi-wl-pprint, will bump with next nixos, presumably+               , trifecta               == 2                , unordered-containers   >= 0.2.3+               , utf8-string            >= 1.0                ---               , LinguisticsTypes       == 0.0.0.*+               , InternedData           == 0.0.0.*    exposed-modules:-    NLP.Scoring.SimpleUnigram-    NLP.Scoring.SimpleUnigram.Default-    NLP.Scoring.SimpleUnigram.Import+    NLP.Scoring.Unigram+    NLP.Scoring.Unigram.Default+    NLP.Scoring.Unigram.Import    default-language:     Haskell2010    default-extensions: BangPatterns+                    , DataKinds                     , DeriveGeneric                     , DeriveDataTypeable+                    , FlexibleInstances                     , GeneralizedNewtypeDeriving                     , MultiParamTypeClasses                     , OverloadedStrings+                    , PolyKinds                     , RecordWildCards+                    , StandaloneDeriving                     , TemplateHaskell                     , TypeFamilies+                    , UnicodeSyntax    ghc-options:     -O2 -funbox-strict-fields@@ -69,7 +88,7 @@                , unordered-containers                , vector                ---               , LinguisticsTypes+               , InternedData                , NaturalLanguageAlphabets   hs-source-dirs:     tests@@ -102,19 +121,22 @@   default-language:     Haskell2010   default-extensions: ScopedTypeVariables+                    , OverloadedStrings                     , TemplateHaskell   build-depends: base                , aeson                , binary                , cereal+               , mtl                , QuickCheck                , tasty                  >= 0.11+               , tasty-hunit            >= 0.9                , tasty-quickcheck       >= 0.8                , tasty-th               >= 0.1                , text                , unordered-containers                ---               , LinguisticsTypes+               , InternedData                , NaturalLanguageAlphabets  

@@ -1,3 +1,15 @@+0.2.1.0+-------++- using polykinded BTI to disallow language name confusion+- fixed up parsing with trifecta-2++0.2.0.0+-------++- generalized the scoring system+- new parser based on trifecta+ 0.1.1.0 ------- 

@@ -1,45 +0,0 @@--- !!! THIS FILE ASSUMES UTF-8 ENCODING !!!------ These are all vowels, but all 'a's are equivalent with respect to this--- scoring. It is only required to give 'EqSet's if you have more than one--- equivalent character. In this EqSet, everything gets a score of 'Eq Vowel'--- (==2).-EqSet Vowel a â ã-EqSet Vowel e-EqSet Vowel i-EqSet Vowel o-EqSet Vowel u--- These are sets of characters belonging to a certain class. In this case, we--- have consonants.-Set Conso    b c d f g h j k m n p q s t v w x y z-Set Liquid   l r-Set Vowel    a\' e\' i\' o\' u\'   ə ɐ æ œ   æh ɔh ɒ ɔ--- Here we say that whenever we see a consonant aligned to the same consonant--- in the other word, give this score.-Eq Conso   4-Eq Liquid  3-Eq Vowel   2--- Whenever we align two consonants that are not equal (or equivalent) we give--- this score.-InSet   Conso    Conso     0-InSet   Conso    Liquid   -1-InSet   Conso    Vowel    -999999-InSet   Liquid   Conso    -1-InSet   Liquid   Liquid   -1-InSet   Liquid   Vowel    -1-InSet   Vowel    Conso    -999999-InSet   Vowel    Liquid   -1-InSet   Vowel    Vowel     0--- How to score a gap in a sequence-Gap         -4--- Later on we want affine gap scoring, it's already here but not used-GapOpen     -4-GapExtend   -4--- Some types of grammars have differently scored prefixes and suffixes-PreSufOpen   -1-PreSufExtend  0--- This score is used when we align the same character but it's one we didn't--- specify in our sets-Match        1--- And finally how to score a mismatch that doesn't fit into the above-Mismatch    -999999

@@ -0,0 +1,85 @@+-- !!! THIS FILE ASSUMES UTF-8 ENCODING !!!++{-+Defaults for scoring whenever more explicit rules do not match.+-}+-- How to score a gap in a sequence.+GapLinear   -4+-- Later on we want affine gap scoring, it's already here but not used+GapOpen     -4+GapExtend   -4+-- Some types of grammars have differently scored prefixes and suffixes+PrefixSuffixOpen   -1+PrefixSuffixExtend  0+-- This score is used when we align the same character but it's one we didn't+-- specify in our sets+Match        1+-- And finally how to score a mismatch that doesn't fit into the above+Mismatch    -999999++++{-+Provide a number of character groups. They will be used to define similar and+equal characters below.+-}++CharGroup C          b c d f g h j k m n p q s t v w x y z+CharGroup L          l r+CharGroup VowelA     A a  Á á  Å å  Ä ä  Æ æ  Ã ã  A\' a\'+CharGroup VowelE     E e  É é  E\' e\'+CharGroup VowelI     I i  Í í  I\' i\'+CharGroup VowelO       o  Ó    Ö   O\' o\'+CharGroup VowelU     u ú ü u\'+CharGroup Vowelx     a å ä ã æ æ á a\' e é e\' ə ɐ æ œ í í i o ö ó u ú ú ü+CharGroup Vowel      $VowelA $VowelE $VowelI $VowelO $VowelU $Vowelx+CharGroup V          {ToLower,ToUpper} $Vowel+-- we'll set up some characters that should be ignored+CharGroup Ignored    ' " ! . , ;  1 2 3 4 5 6 7 8 9 0++++{-+Set up similarity scores between groups. These should go from lower to higher+scores, as latter rules overwrite earlier rules.+-}++Similarity $L $L -1++-- these two rules do the same, because 'V' is given the {ToLower,ToUpper}+-- extension in CharGroup.+Similarity $V $V 0+Similarity {ToLower,ToUpper} $Vowel {ToLower,ToUpper} $Vowel    0++Similarity $C $C 1+-- these are not the same character, but treated as highly similar, so we end+-- up giving a high score.+Similarity $VowelA $VowelA 2++++{-+And now, we just look at individual characters, maybe qualified. Now, each+character is only equal to itself, we just use the character groups to provide+easy enumeration. However, the extensions {ToLower,ToUpper} expand equality.+Say, V = {A, ä}. Then Equality V 2 means A=A and ä=ä with score 2. Including+{ToLower,ToUpper} yields A=A, A=a, a=A, a=a and Ä=Ä, Ä=ä, ä=Ä, ä=ä with score+2; but NOT A=ä!+-}+Equality {ToLower,ToUpper} $V 2+Equality {ToLower,ToUpper} $L 3+Equality {ToLower,ToUpper} $C 4++++{-+These characters should be *ignored* when gaps are considered. They are+essentially "not in the word" or "free", but the scores can be set, of course.+Fst and Snd designate which of the two tapes we talk about. If this is missing,+the ignored characters are ignored on both tapes.+-}++IgnoredFst {ToLower,ToUpper} $Ignored 0+IgnoredSnd {ToLower,ToUpper} $Ignored 0+Ignored                      $Ignored 0+

@@ -0,0 +1,64 @@+-- These are all vowels, but all 'a's are equivalent with respect to this+-- scoring. It is only required to give 'EqSet's if you have more than one+-- equivalent character. In this EqSet, everything gets a score of 'Eq Vowel'+-- (==2).+EqSet Vowel a å æ 4 Я я Α α ʌ а+EqSet Vowel e ê ɛ 3 Ε ε+EqSet Vowel i I y Y ɨ ʸ И и Η η Ι ι υ+EqSet Vowel o ø 0 O Ω ω+EqSet Vowel u ʏ У у Ю ю ʊ+-- These are sets of characters belonging to a certain class. In this case, we+-- have consonants.+Set Conso    c q w x 6 9 ɲ ʔ ʕ+Set Liquid   r 7 ʁ+EqSet Conso  h H ħ Х х x Χ χ+EqSet Conso  Б б B b Β β+EqSet Conso  В в V v+EqSet Conso  Г г G g Γ γ+EqSet Conso  Д д D d Δ δ ð ɣ+EqSet Conso  Ж ж ʒ č+EqSet Conso  З з z Z Ζ ζ+EqSet Conso  Й й j J+EqSet Conso  К к K k Κ κ+EqSet Liquid  Л л l L Λ λ ƛ+EqSet Conso  М м m M Μ μ+EqSet Conso  Н н N n Ν ν+EqSet Conso  П п P p Π π+EqSet Р р R r Ρ ρ+EqSet Conso  С с S s Σ σ+EqSet Conso  Т т t T Τ τ+EqSet Conso  Ф ф F f V v υ Φ φ+EqSet Conso  Ц ц+EqSet Conso  Ч ч+EqSet Conso  Ш ш ʃ š+EqSet Conso  Щ щ+EqSet Conso  Ь ь+EqSet Conso  Θ θ+EqSet Conso  Ξ ξ+EqSet Conso  Ψ ψ+-- Here we say that whenever we see a consonant aligned to the same consonant+-- in the other word, give this score.+Eq Conso   4+Eq Liquid  3+Eq Vowel   2+-- Whenever we align two consonants that are not equal (or equivalent) we give+-- this score.+InSet   Conso    Conso     0+InSet   Conso    Liquid   -1+InSet   Conso    Vowel    -999999+InSet   Liquid   Conso    -1+InSet   Liquid   Liquid   -1+InSet   Liquid   Vowel    -1+InSet   Vowel    Conso    -999999+InSet   Vowel    Liquid   -1+InSet   Vowel    Vowel     0+-- How to score a gap in a sequence+Gap         -4+-- Later on we want affine gap scoring, it's already here but not used+GapOpen     -4+GapExtend   -1+-- This score is used when we align the same character but it's one we didn't+-- specify in our sets+Match        1+-- And finally how to score a mismatch that doesn't fit into the above+Mismatch    -999999

@@ -24,7 +24,7 @@ import           System.Random.MWC import           Text.Printf -import NLP.Text.BTI+import           Data.ByteString.Interned   @@ -36,11 +36,11 @@                     (UCHS.size hmsK) (CIS.size cisK) (-1 :: Int)           defaultMain             [ bgroup "  100 keys" [ bench "HashMap.Strict" $ whnf (\k -> UCHS.lookupDefault  0 k hmsH) (VU.head keys)-                                  , bench "IntMap.Strict" $ whnf (\k -> CIS.findWithDefault 0 k cisH) (getBTI $ VU.head keys)+                                  , bench "IntMap.Strict" $ whnf (\k -> CIS.findWithDefault 0 k cisH) (getIBS $ VU.head keys)                                   , bench "HashTable" $ whnf (\k -> htLookup htH k)               (VU.head keys)                                   ]             , bgroup "10000 keys" [ bench "HashMap.Strict" $ whnf (\k -> UCHS.lookupDefault  0 k hmsK) (VU.head keys)-                                  , bench "IntMap.Strict" $ whnf (\k -> CIS.findWithDefault 0 k cisK) (getBTI $ VU.head keys)+                                  , bench "IntMap.Strict" $ whnf (\k -> CIS.findWithDefault 0 k cisK) (getIBS $ VU.head keys)                                   , bench "HashTable" $ whnf (\k -> htLookup htK k)               (VU.head keys)                                   ] --            , bgroup "  100 known"   [ bench "uchsH" $ whnf (\ks -> VU.sum $ VU.map (\k -> UCHS.lookupDefault  0 k hmsH) ks) (VU.take 100 keys)@@ -59,25 +59,25 @@ {-# Inline htLookup #-}  -type HTB = HT.BasicHashTable BTI Double+type HTB = HT.BasicHashTable (IBS ()) Double  setupEnv = do   -- create keys   strs :: [String] <- replicateM 10000 rString   -- scores to look up   scrs :: [Double] <- replicateM 10000 $ randomRIO (0 , 9)-  -- create BTI keys-  let keys = map (bti . fromString) strs+  -- create IBS keys+  let keys = map (ibsFrom) strs   -- create random keys, mostly not in strs   unks :: [String] <- replicateM 10000 rString-  let sknu = map (bti . fromString) unks+  let sknu = map ibsFrom unks   -- for 100 keys   let hmsK = UCHS.fromList $ take 100 $ zip keys              scrs-  let cisK =  CIS.fromList $ take 100 $ zip (map getBTI keys) scrs+  let cisK =  CIS.fromList $ take 100 $ zip (map getIBS keys) scrs   htH :: HTB <- HT.fromList $ take 100 $ zip keys scrs   -- for 10 000 keys   let hmsM = UCHS.fromList $ zip keys              scrs-  let cisM =  CIS.fromList $ zip (map getBTI keys) scrs+  let cisM =  CIS.fromList $ zip (map getIBS keys) scrs   htK :: HTB <- HT.fromList $ zip keys scrs   return (VU.fromList keys , VU.fromList sknu , (hmsK,cisK,htH) , (hmsM,cisM,htK) ) 

@@ -2,18 +2,25 @@ module Main where  import           Control.Applicative+import           Control.Monad.Except+import           Data.Either import           Data.HashMap.Strict (fromList,union)+import           Data.HashMap.Strict (lookupDefault, lookup) import           Debug.Trace+import           Prelude hiding (lookup) import qualified Data.Aeson as A import qualified Data.Binary as B+import qualified Data.HashMap.Strict as HM import qualified Data.Serialize as S+import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck import           Test.Tasty.TH -import           NLP.Text.BTI+import           Data.ByteString.Interned -import           NLP.Scoring.SimpleUnigram-import           NLP.Scoring.SimpleUnigram.Default+import           NLP.Scoring.Unigram+import           NLP.Scoring.Unigram.Default+import           NLP.Scoring.Unigram.Import   @@ -25,25 +32,43 @@ -- for equality.  prop_Aeson ( xs :: [((String,String),Double)]-           , ( (gs :: Double, go :: Double, ge :: Double)+           , smm :: [(String,Double)]+           , ( (gl :: Double, go :: Double, ge :: Double)              , (dm :: Double, di :: Double)-             , (pso :: Double, pse :: Double)+             , (psl :: Double, pso :: Double, pse :: Double)              )            )-  = Just def' == A.decode (A.encode def')+  = Just def' == (either error id $ A.eitherDecode (A.encode def'))   where def  = clvDefaults-        xs'  = fromList $ map (\((x,y),s) -> ((btiFromCS x,btiFromCS y),s)) xs-        def' = def { simpleScore  = simpleScore def `union` xs'-                   , gapScore     = gs-                   , gapOpen      = go-                   , gapExt       = ge-                   , defMatch     = dm-                   , defMismatch  = di-                   , preSufOpen   = pso-                   , preSufExt    = pse+        xs'  = fromList $ map (\((x,y),s) -> ((ibsFrom x, ibsFrom y),s)) xs+        smm' = fromList $ map (\(x,s) -> (ibsFrom x, s)) smm+        def' = def { usUnigramMatch           = usUnigramMatch  def `union` xs'+                   , usUnigramInsertFstK      = usUnigramInsertFstK def `union` smm'+                   , usUnigramInsertSndL      = usUnigramInsertSndL def `union` smm'+                   , usGapLinear              = gl+                   , usGapOpen                = go+                   , usGapExtension           = ge+                   , usDefaultMatch           = dm+                   , usDefaultMismatch        = di+                   , usPrefixSuffixLinear     = psl+                   , usPrefixSuffixOpen       = pso+                   , usPrefixSuffixExtension  = pse                    } +-- Everything here should succeed +case_Import_uni01 = do+  eu <- runExceptT $ fromFile False "./tests/uni01.score"+  assertBool ("uni01 load should succeed but fails with\n" ++ (either errorToString show eu)) $ isRight eu+  let Right u = eu+  assertEqual "EqualScore Consonant 4 F~f" (Just 4) . lookup (ibsText "F", ibsText "f") $ usUnigramMatch u+  assertEqual "GapLinear" (-4) $ usGapLinear u++-- Here we test that the parser should fail on wrong input++case_Import_uni02 = do+  eu <- runExceptT $ fromFile False "./tests/uni02.score"+  assertBool "uni02 load should fail" $ isLeft eu  main :: IO () main = $(defaultMainGenerator)

@@ -0,0 +1,6 @@+CharGroup FG    F f G g+CharGroup BCD   b c d+Similarity $FG $FG 4++GapLinear -4+

@@ -0,0 +1,8 @@+EqualScore Consonant  4+SimilarScore   Consonant    Consonant     0+SimilarChars Consonant    b c d+EqualChars Consonant F f G g+EqualChars Vowel a b+IgnoredChars   9 0+GapLinear   -4+GapExtend   -4