{- This file is part of link-relations.
-
- Written in 2015 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Applicative
import Control.Monad (guard, liftM)
import Data.Char (toUpper)
import Data.Csv
import Data.Foldable (mapM_)
import Data.Int (Int64)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mconcat)
import Prelude hiding (mapM_)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.Vector as V (length, toList)
-------------------------------------------------------------------------------
-- Configuration
-------------------------------------------------------------------------------
-- | The IANA link relations registry data.
csvFile :: FilePath
csvFile = "util/link-relations-1.csv"
-- | Haskell source template into which the data needs to be inserted.
hsTemplateFile :: FilePath
hsTemplateFile = "util/template.hs"
-- | Where to write the result of writing formatted data into the template.
outputFile :: FilePath
outputFile = "src/Web/LinkRelations.hs.new"
-- | Y-M-D date specifying the time of the last update to the IANA registry.
lastUpdated :: BL.ByteString
lastUpdated = "2015-01-21"
-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------
data LinkRelInfo = LinkRelInfo
{ lrName :: BL.ByteString
, lrDescription :: BL.ByteString
, lrReferences :: BL.ByteString
, lrNotes :: BL.ByteString
}
deriving (Show)
instance FromRecord LinkRelInfo where
parseRecord v =
if V.length v == 4
then LinkRelInfo <$>
v .! 0 <*>
v .! 1 <*>
v .! 2 <*>
v .! 3
else empty
data TemplateLine = TemplText BL.ByteString | TemplVar BL.ByteString
-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------
-- | Like 'map', but applies one function to the first element and a different
-- function to the rest of the elements.
mapSep :: (a -> b) -> (a -> b) -> [a] -> [b]
mapSep _ _ [] = []
mapSep f g (x:xs) = f x : map g xs
-- | Like 'BLC.map', but applies the function /only/ to the first byte.
mapFstB :: (Char -> Char) -> BL.ByteString -> BL.ByteString
mapFstB f s =
case BLC.uncons s of
Nothing -> s
Just (c, r) -> f c `BLC.cons` r
--mapTail :: (a -> a) -> [a] -> [a]
--mapTail _ [] = []
--mapTail f (x:xs) = x : map f xs
-- | Convert @this-is-some-name@ to @ThisIsSomeName@.
toCamel :: BL.ByteString -> BL.ByteString
toCamel = mconcat . map (mapFstB toUpper) . BLC.split '-'
-- | Apply a function to the first element.
applyFst :: (a -> c) -> (a, b) -> (c, b)
applyFst f (x, y) = (f x, y)
-- | Break a list of words into two lists. The first is the maximal prefix
-- whose length (including spaces between words) is at most N (unless the first
-- word is longer than N, in which case that word is returned), and the second
-- list is the rest of the word list.
breakN :: Int64 -> [BL.ByteString] -> ([BL.ByteString], [BL.ByteString])
breakN len ws = applyFst reverse $ f 0 [] ws
where
f _ xs [] = (xs, [])
f n [] (y:ys) =
let l = n + BL.length y -- 'n' should be 0 here
in if len <= l
then ([y], ys)
else f l [y] ys
f n xs r@(y:ys) =
let l = n + 1 + BL.length y
in if len < l
then (xs, r)
else f l (y:xs) ys
-- | Apply 'breakN' repeatedly on a word list, splitting it into a list of
-- word-lists.
splitN :: Int64 -> [BL.ByteString] -> [[BL.ByteString]]
splitN len = f
where
f ws =
case breakN len ws of
(xs, []) -> [xs]
(xs, ys) -> xs : f ys
-- | Read a text file into a list of lines.
readLines :: FilePath -> IO [BL.ByteString]
readLines = liftM BLC.lines . BL.readFile
-------------------------------------------------------------------------------
-- Haddock Comments
-------------------------------------------------------------------------------
-- | Try to detect a link by suffix. Return remaining prefix and a suffix to
-- append after link conversion.
stripLinkSuffix :: BL.ByteString -> Maybe (BL.ByteString, BL.ByteString)
stripLinkSuffix w =
case BLC.unsnoc w of
Just (t, ']') -> Just (t, BL.empty)
Just (t, ',') ->
case BLC.unsnoc t of
Just (r, ']') -> Just (r, BLC.singleton ',')
_ -> Nothing
_ -> Nothing
-- | If the given word is a link, convert to haddock format.
detectLink :: BL.ByteString -> Maybe BL.ByteString
detectLink w =
let rfcPrefix = "[RFC"
rfcDrop = 4
httpPrefix = "[http"
httpDrop = 1
otherPrefix = "["
otherDrop = 1
iana = "<https://www.iana.org/go/"
in case stripLinkSuffix w of
Just (t, r)
| rfcPrefix `BL.isPrefixOf` t -> Just $
let num = BL.drop rfcDrop t
in iana <> "rfc" <> num <> " RFC " <> num <> ">" <> r
| httpPrefix `BL.isPrefixOf` t -> Just $
"<" <> BL.drop httpDrop t <> ">" <> r
| otherPrefix `BL.isPrefixOf` t -> Just $
let name = BL.drop otherDrop t
in iana <> name <> " " <> name <> ">" <> r
| otherwise -> Nothing
Nothing -> Nothing
-- | Escape some formatting characters in a non-link word.
escapeWord :: BL.ByteString -> BL.ByteString
escapeWord = BLC.foldr f BL.empty
where
f c s =
if c `elem` ['/', '"', '\'']
then '\\' `BLC.cons` c `BLC.cons` s
else c `BLC.cons` s
-- | Convert links, espcape characters, do some comment text processing.
processWords :: [BL.ByteString] -> [BL.ByteString]
processWords = map $ \ s -> fromMaybe (escapeWord s) $ detectLink s
-- | Format a paragraph as haddock identifier comment lines.
toComment :: BL.ByteString -> [BL.ByteString]
toComment s =
let mkFirst = ("-- | " <>) . BLC.unwords
mkRest = ("-- " <>) . BLC.unwords
in case breakN 74 $ processWords $ BLC.words s of
(xs, []) -> [mkFirst xs]
(xs, ys) -> mkFirst xs : map mkRest (splitN 76 ys)
-- | Format a paragraph as haddock identifier non-first comment lines.
toCommentCont :: BL.ByteString -> [BL.ByteString]
toCommentCont =
let mkline = ("-- " <>) . BLC.unwords
in map mkline . splitN 76 . processWords . BLC.words
-------------------------------------------------------------------------------
-- Registry Data
-------------------------------------------------------------------------------
-- | Given the CSV file path, read it into a list of linkrel records.
readData :: FilePath -> IO [LinkRelInfo]
readData file = do
csv <- BL.readFile file
case decode HasHeader csv of
Left err -> error $ "CSV parsing failed: " ++ err
Right lrs -> return $ V.toList lrs
-------------------------------------------------------------------------------
-- Template
-------------------------------------------------------------------------------
-- | Detect whether a template line is literal text or a variable.
parseLine :: BL.ByteString -> TemplateLine
parseLine s = fromMaybe (TemplText s) $ do
(h, t) <- BLC.uncons s
guard $ h == '$'
(h', t') <- BLC.uncons t
guard $ h' == '{'
(i, l) <- BLC.unsnoc t'
guard $ l == '}'
return $ TemplVar i
-- | Interpolate the variable values into a template.
render :: (BL.ByteString -> BL.ByteString) -> [TemplateLine] -> BL.ByteString
render f =
let g (TemplText s) = s `BLC.snoc` '\n'
g (TemplVar v) = f v
in mconcat . map g
-- | Read and parse a template file.
readTemplate :: FilePath -> IO [TemplateLine]
readTemplate = liftM (map parseLine) . readLines
-------------------------------------------------------------------------------
-- Haskell Code Generation
-------------------------------------------------------------------------------
-- date -----------------------------------------------------------------------
-- | Registry revision date to insert into haddock comment.
varDate :: BL.ByteString
varDate = "-- /" <> lastUpdated <> "/\n"
-- exports --------------------------------------------------------------------
-- | Given a linkrel name, get a matching Haskell variable name.
toSymName :: BL.ByteString -> BL.ByteString
toSymName = ("rel" <>) . toCamel
-- | Given a linkrel name, format an export source line.
formatExport :: BL.ByteString -> BL.ByteString
formatExport = (" , " <>) . toSymName
-- | Given a list of linkrel names, get the exports text.
mkVarExports :: [BL.ByteString] -> BL.ByteString
mkVarExports = BLC.unlines . map formatExport
-- ctors ----------------------------------------------------------------------
-- | Given a linkrel name, get a matching data constructor name.
toCtorName :: BL.ByteString -> BL.ByteString
toCtorName = ("Rel" <>) . toCamel
-- | Given a linkrel name, format a data constructor source line.
formatCtor :: BL.ByteString -> BL.ByteString
formatCtor = (" | " <>) . toCtorName
-- | Given a list of linkrel names, get the constructors text.
mkVarCtors :: [BL.ByteString] -> BL.ByteString
mkVarCtors = BLC.unlines . map formatCtor
-- hashmap --------------------------------------------------------------------
-- | Given a linkrel name, format a hashmap pair source line.
formatPair :: Bool -> BL.ByteString -> BL.ByteString
formatPair first name =
let c = if first then "[" else ","
in " " <> c <> " (\"" <> name <> "\", " <> toCtorName name <> ")"
-- | Given a list of linkrel names, get the hashmap text.
mkVarHashmap :: [BL.ByteString] -> BL.ByteString
mkVarHashmap = BLC.unlines . mapSep (formatPair True) (formatPair False)
-- tostr ----------------------------------------------------------------------
-- | Given a linkrel name, format a to-string source line.
formatMatch :: BL.ByteString -> BL.ByteString
formatMatch name = " " <> toCtorName name <> " -> \"" <> name <> "\""
-- | Given a list of linkrel names, get the tostr text.
mkVarTostr :: [BL.ByteString] -> BL.ByteString
mkVarTostr = BLC.unlines . map formatMatch
-- rels -----------------------------------------------------------------------
-- | Given a linkrel, format a haddock comment.
formatRelComment :: LinkRelInfo -> [BL.ByteString]
formatRelComment lr =
let fmt pref s =
if BL.null s
then []
else "--" : toCommentCont (pref <> s)
in toComment (lrDescription lr) ++
fmt "Reference: " (lrReferences lr) ++
fmt "Note: " (lrNotes lr)
-- | Given a linkrel, format relation symbol lines.
formatRel :: LinkRelInfo -> [BL.ByteString]
formatRel lr =
let name = lrName lr
sym = toSymName name
ctor = toCtorName name
in formatRelComment lr ++
[ sym <> " :: LinkRelation"
, sym <> " = " <> ctor
]
-- | Given a list of linkrels , get the rels text.
mkVarRels :: [LinkRelInfo] -> BL.ByteString
mkVarRels = BLC.unlines . intercalate [BL.empty] . map formatRel
-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------
main :: IO ()
main = do
lrs <- readData csvFile
templ <- readTemplate hsTemplateFile
let lrNames = map lrName lrs
getVar s
| s == "date" = varDate
| s == "exports" = mkVarExports lrNames
| s == "ctors" = mkVarCtors lrNames
| s == "hashmap" = mkVarHashmap lrNames
| s == "tostr" = mkVarTostr lrNames
| s == "rels" = mkVarRels lrs
| otherwise =
error $ "No value defined for variable " ++ show s
BL.writeFile outputFile $ render getVar templ
putStrLn "Done."