hackage-server/src/Distribution/Server/Features/PackageList/MStats.hs at fc4c52742eee5edc80cdb79647e0f20755ffc28e · haskell/hackage-server · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, ConstraintKinds #-}
module Distribution.Server.Features.PackageList.MStats
  ( parseM
  , sumMStat
  , getListsTables
  , getCode
  , getHCode
  , getSections
  , MStats(..)
  ) where

import           Commonmark
import           Commonmark.Extensions
import           Control.Monad.Identity
import qualified Data.ByteString.Lazy          as BS
                                                ( ByteString
                                                , toStrict )
import qualified Data.Text                     as T
import qualified Data.Text.Encoding            as T
import qualified Data.Text.Encoding.Error      as T
                                                ( lenientDecode )

-- parses markdown into statistics needed for readmeScore
parseM :: BS.ByteString -> FilePath -> Either ParseError [MarkdownStats]
parseM md name = runIdentity
  (commonmarkWith (pipeTableSpec <> defaultSyntaxSpec) name txt)
  where txt = T.decodeUtf8With T.lenientDecode . BS.toStrict $ md

data MarkdownStats = NotImportant MStats |
                     HCode MStats |
                     Code MStats |
                     Section MStats |
                     Table Int MStats | -- Int of rows
                     PText MStats |
                     List Int MStats -- Int of elements
    deriving (Show)

data MStats = MStats Int Int --number of pictures, number of chars
  deriving Show

instance Monoid MStats where
  mempty = MStats 0 0

instance Rangeable MStats where
  ranged = const id

instance HasAttributes MStats where
  addAttributes = const id

instance Semigroup MStats where
  (MStats a b) <> (MStats c d) = MStats (a + c) (b + d)

-- Getter functions

getCode :: [MarkdownStats] -> (Int, Int) -- number of code blocks, size of code
getCode []                           = (0, 0)
getCode (Code  (MStats codeT _) : xs) = (1, codeT) >< getCode xs
getCode (HCode (MStats codeT _) : xs) = (1, codeT) >< getCode xs
getCode (_                     : xs) = getCode xs

getHCode :: [MarkdownStats] -> (Int, Int) -- number of code blocks, size of code
getHCode []                           = (0, 0)
getHCode (HCode (MStats codeT _) : xs) = (1, codeT) >< getHCode xs
getHCode (_                     : xs) = getHCode xs

getSections :: [MarkdownStats] -> Int -- number of code blocks, size of code
getSections []               = 0
getSections (Section _ : xs) = 1 + getSections xs
getSections (_         : xs) = getSections xs

sumMStat :: [MarkdownStats] -> MStats
sumMStat []       = mempty
sumMStat (x : xs) = case x of
  (NotImportant a) -> a <> sumMStat xs
  (Section      a) -> a <> sumMStat xs
  (List  _ a     ) -> a <> sumMStat xs
  (Table _ a     ) -> a <> sumMStat xs
  (HCode a       ) -> a <> sumMStat xs
  (Code  a       ) -> a <> sumMStat xs
  (PText a       ) -> a <> sumMStat xs

getListsTables :: [MarkdownStats] -> Int
getListsTables []                 = 0
getListsTables ((List  a _) : ys) = a + getListsTables ys
getListsTables ((Table a _) : ys) = a + getListsTables ys
getListsTables (_           : ys) = getListsTables ys

-- helper
(><) :: (Int, Int) -> (Int, Int) -> (Int, Int)
(><) (a, b) (c, d) = (a + c, b + d)

-- INSTANCES
instance Rangeable [MarkdownStats] where
  ranged = const id

instance HasAttributes [MarkdownStats] where
  addAttributes = const id

instance HasPipeTable MStats [MarkdownStats] where
  pipeTable _ _ rows = [Table (length rows) (mconcat $ mconcat <$> rows)]

instance IsInline MStats where
  lineBreak = MStats 0 1
  softBreak = MStats 0 1
  str t = MStats 0 (T.length t)
  entity t = MStats 0 (T.length t)
  escapedChar _ = MStats 0 1
  emph   = id
  strong = id
  link _ _ a = a
  image _ _ (MStats a b) = MStats (a + 1) b
  code t = MStats 0 (T.length t)
  rawInline _ t = MStats 0 (T.length t)

instance IsBlock MStats [MarkdownStats] where
  paragraph a = [PText a]
  plain a = [PText a]
  thematicBreak = [NotImportant mempty]
  blockQuote    = id
  codeBlock language codeT | language == T.pack "haskell" = [HCode (code codeT)]
                           | otherwise                    = [Code (code codeT)]
  heading _ a = [Section a]
  rawBlock _ _ = [NotImportant mempty]
  referenceLinkDefinition _ _ = [NotImportant mempty]
  list _ _ l = [List (length l + sumLT l) (mconcat $ sumMStat <$> l)]
    where sumLT a = sum (getListsTables <$> a)