diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,15 @@ # Changelog for pandoc-filter-indent ## Unreleased changes +## Unreleased changes + +0.2.2.0 Jan 12 2020 + - Fixed problem with declaring too few columns in LaTeX + - Inline code formatting + - Removed indent marks from parenthesised operators: "`(+)" + - Removed indent marks from functions promoted to operators like "`mappend`" + - Fixed rendering of indent mark at the start of the column + 0.1.0.0 Dec 1 2020 - Initial release supporting LaTeX and HTML output diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -371,8 +371,8 @@ - and operators in standard type classes: * `Control.Monad`: `>>=`, `>>`, `>=>` * `Control.Alternative`: `<|>` - * `Control.Functor`: `<*>` - * `Control.Applicative`: `<*>`, `<*`, and `*>` + * `Control.Functor`: `<$>` + * `Control.Applicative`: `<*>`, `<$>`, `<*`, and `*>` * `Data.Semigroup.<>` shown as $\diamond$ * `Data.Ord`: `/=`, `>=`, `<=`, `>`, `<` * `Num`: `+`, `-`, `*`, `/`, @@ -401,6 +401,12 @@ This mapping should be easily changed in a single place in code. _Please let me know if there is a question about any other token types!_ + +## Formatting inline code + +To format inline code we lookup `inline-code` in YAML metadata, +and append it to attributes of each inline code fragment. +By default it is `haskell`. ## Safe escaping diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,44 +1,80 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} module Main where import Text.Pandoc.JSON +import Text.Pandoc.Walk (walk) import Text.Pandoc.Definition () -import Data.String (fromString, IsString) -import Data.Maybe (fromMaybe) -import Data.Text (Text) +import Data.String (IsString) +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map +import Data.Text(Text) import qualified Data.Text as T - -import Debug.Trace(trace) + +import qualified Token.Haskell (tokenizer) +import Filter (renderBlock, renderInline) +import FindColumns (findColumns) +import Alignment (Processed) -import Token.Haskell -import GHC.SyntaxHighlighter -import Filter -import FindColumns +data Options = Options { + inlineSyntax :: Text + } main :: IO () -main = toJSONFilter blockFormatter +main = toJSONFilter runner +-- | Main body of Pandoc filter. +-- Reads format option, metadata, +-- and calls `walk` with `blockFormatter`. +runner :: Maybe Format -> Pandoc -> Pandoc +runner (fromMaybe (Format "text") -> format) input@(Pandoc (Meta meta) _) = + walk (blockFormatter opts format) input + where + opts = case Map.lookup "inline-code" meta of + Nothing -> Options "haskell" -- default + Just (MetaString s) -> Options s -- never needed? + Just (MetaInlines [Str s]) -> Options s + Just otherValue -> error $ "inline-code: meta should be a string but is: " <> show otherValue + -- | Select the desired format output then process it. -blockFormatter :: Maybe Format -> Block -> Block -blockFormatter format (CodeBlock attrs content) = - codeFormatter (fromMaybe (Format "text") format) attrs content --- Do not touch other blocks than 'CodeBlock' -blockFormatter _ x = x +-- Run tokenizer, analysis, and formatter. +-- +-- For non-CodeBlocks it runs `inlineFormatter`. +-- Fallback to original input, if failed to tokenize. +blockFormatter :: Options + -> Format -- ^ Output format, defaults to "plain" if not found + -> Block + -> Block +blockFormatter _opts format (CodeBlock attrs content) = + case fmap findColumns $ getTokenizer attrs content of + Just processed -> renderBlock format attrs processed + Nothing -> CodeBlock attrs content -- fallback +-- Do not touch other blocks than 'CodeBock' +blockFormatter opts format x = + walk (inlineFormatter opts format) x --- | Run tokenizer, analysis, and formatter. +-- | Select the desired format output then process it. +-- Run tokenizer, and inline formatter. -- Fallback to original input, if failed to tokenize. -codeFormatter :: Format -- ^ Output format, defaults to "text" if not found - -> Attr -- ^ Code block attributes - -> Text -- ^ Code block content - -> Block -codeFormatter format attrs content = - case fmap findColumns $ aTokenizer content of - Just processed -> render format attrs processed - Nothing -> CodeBlock attrs content -- fallback +inlineFormatter :: Options + -> Format -- ^ Output format, defaults to "plain" if not found + -> Inline + -> Inline +inlineFormatter Options {inlineSyntax} format (Code attrs txt) = + case getTokenizer attrs txt of + Just processed -> renderInline format attrs $ map discardLoc processed + Nothing -> Code attrs txt -- fallback where - aTokenizer | isHaskell attrs = Token.Haskell.tokenizer - | otherwise = \_ -> Nothing + discardLoc (a, _, b) = (a, b) + addClass (a, classes, b) | inlineSyntax /= "" = (a, inlineSyntax:classes, b) + addClass o = o +inlineFormatter _opts _ x = x + +-- | Pick tokenizer depending on options. +getTokenizer attrs | isHaskell attrs = Token.Haskell.tokenizer + | otherwise = \_ -> Nothing -- | Check if the code block is tagged as Haskell. isHaskell :: (Foldable t, Eq a1, IsString a1) => diff --git a/pandoc-filter-indent.cabal b/pandoc-filter-indent.cabal --- a/pandoc-filter-indent.cabal +++ b/pandoc-filter-indent.cabal @@ -4,16 +4,18 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 556363e65a61ebed2e66c3756278177ca371c24b119a21fbad59d9b26059d56e +-- hash: 506b1106212a197e0660fa32faa540c66b93cd8f032fb5b7863977a230d9ebd9 name: pandoc-filter-indent -version: 0.2.1.0 +version: 0.2.2.0 synopsis: Pandoc filter formatting Haskell code fragments using GHC lexer. description: Formats marked code fragments, and allows `pandoc` to safely process rest of your literate program: . > ```{.haskell} . + . Usage: + . > stack install pandoc-filter-indent > pandoc --filter pandoc-filter-indent -f input.md -o output.pdf > pandoc --filter pandoc-filter-indent -f input.md -o output.html @@ -26,10 +28,10 @@ and creates tabular code structures from indentation. It uses GHC lexer to assure that latest features are always parsed correctly. . - Please see the README on GitHub at + Please see the README on GitHub at category: Text -homepage: https://github.com/mjgajda/pandoc-filter-indent#readme -bug-reports: https://github.com/mjgajda/pandoc-filter-indent/issues +homepage: https://github.com/mgajda/pandoc-filter-indent#readme +bug-reports: https://github.com/mgajda/pandoc-filter-indent/issues author: Michał J. Gajda maintainer: mjgajda@migamake.com copyright: AllRightsReserved @@ -42,7 +44,7 @@ source-repository head type: git - location: https://github.com/mjgajda/pandoc-filter-indent + location: https://github.com/mgajda/pandoc-filter-indent library exposed-modules: @@ -86,9 +88,11 @@ , base >=4.7 && <5 , blaze-html ==0.9.1.2 , blaze-markup + , containers , ghc-syntax-highlighter ==0.0.5.0 , optics-core , optics-th + , optparse-applicative , pandoc-filter-indent , pandoc-types , text ==1.2.4.0 @@ -104,6 +108,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HaTeX + , QuickCheck , base >=4.7 && <5 , blaze-html ==0.9.1.2 , blaze-markup @@ -112,5 +117,6 @@ , optics-th , pandoc-filter-indent , pandoc-types + , quickcheck-text , text ==1.2.4.0 default-language: Haskell2010 diff --git a/src/Alignment.hs b/src/Alignment.hs --- a/src/Alignment.hs +++ b/src/Alignment.hs @@ -18,7 +18,15 @@ deriving (Eq, Ord, Show) -- | Records tokenized and converted to common token format. -type Processed = (MyTok, MyLoc, Text, Maybe Int, Maybe (Align, Int)) +type Processed = (MyTok -- ^ Token type + ,MyLoc -- ^ Token location + ,Text -- ^ Text content + ,Maybe Int -- ^ Indent column + ,Maybe (Align -- ^ Alignment mark + ,Int) -- ^ Alignment column + ) + + -- | Access text content. tokenType :: Field1 a a MyTok MyTok => Lens' a MyTok diff --git a/src/Filter.hs b/src/Filter.hs --- a/src/Filter.hs +++ b/src/Filter.hs @@ -5,39 +5,53 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -- | Filtering a single code block. -module Filter where +module Filter(renderBlock, renderInline) where import Text.Pandoc.JSON -import Data.Text (Text) import qualified Data.Text as T import Prelude hiding(getLine) -import Token.Haskell -import FindColumns -import Alignment -import Render.ColSpan -import qualified Render.Debug(render) +import FindColumns ( tableColumns ) +import Alignment ( Processed ) +import Token ( MyTok ) +import Render.ColSpan ( colspans, numColSpans ) +import qualified Render.Debug import qualified Render.Latex import qualified Render.HTML - import Debug.Trace(trace) -- | Render a list of `Processed` token records into the target output format. -render :: Format -- ^ Format string - -> Attr -- ^ Attributes - -> [Processed] -- ^ Data about alignment - -> Block +renderBlock :: Format -- ^ Format string + -> Attr -- ^ Attributes + -> [Processed] -- ^ Data about alignment + -> Block +renderBlock (Format "text" ) _attrs = RawBlock (Format "html" ) . T.pack . show . map (sum . map (\(_,c,_) -> c)) . colspans +--renderBlock (Format "text" ) attrs = CodeBlock attrs . Render.Debug.render +renderBlock (Format "latex") _attrs = RawBlock (Format "latex") . processLatex +renderBlock (Format "html" ) _attrs = RawBlock (Format "html" ) . processHTML +-- Debugging option +renderBlock other attrs = CodeBlock attrs . T.pack . (show other <>) . show + +sumColSpans = map (sum . map (\(_,c,_) -> c)) . colspans + +-- TODO: inline should strip colspans, and ignore table +-- | Render a list of `Processed` token records into the target output format. +renderInline :: Format -- ^ Format string + -> Attr -- ^ Attributes + -> [(MyTok, T.Text)] -- ^ Data about alignment + -> Inline --render "text" attrs aligned = RawBlock (Format "latex") $ processLatex aligned -- debug -render (Format "text" ) attrs = CodeBlock attrs . Render.Debug.render -render (Format "latex") attrs = RawBlock (Format "latex") . processLatex -render (Format "html" ) attrs = RawBlock (Format "html" ) . processHTML +renderInline (Format "text" ) attrs = Code attrs . Render.Debug.renderInline +renderInline (Format "latex") _attrs = RawInline (Format "latex") . Render.Latex.latexInline +renderInline (Format "html" ) _attrs = RawInline (Format "html" ) . Render.HTML.htmlInline -- Debugging option -render other attrs = CodeBlock attrs . T.pack . show +renderInline other attrs = Code attrs . T.pack . show -- | Convert a list of input token records to raw LaTeX. processLatex :: [Processed] -> T.Text -processLatex processed = Render.Latex.latexFromColSpans (length $ tableColumns processed) - $ colspans processed +processLatex processed = Render.Latex.latexFromColSpans (numColSpans processed) cs + where + cs = colspans processed -- | Convert a list of input token records to raw HTML. processHTML :: [Processed] -> T.Text diff --git a/src/FindColumns.hs b/src/FindColumns.hs --- a/src/FindColumns.hs +++ b/src/FindColumns.hs @@ -25,14 +25,16 @@ import Debug.Trace -- | Records tokenized and converted to common token format. -type Unanalyzed = (MyTok, MyLoc, Text, Maybe Int ) +type Unanalyzed = (MyTok, MyLoc, Text + , Maybe Int -- ^ Indent for entire line + ) -- | Records aligned, but without column numbers yet. -type Aligned = (MyTok -- token type - ,MyLoc -- text start location - ,Text -- text content - ,Maybe Int -- indent in this column - ,Maybe Align -- alignment +type Aligned = (MyTok -- ^ token type + ,MyLoc -- ^ text start location + ,Text -- ^ text content + ,Maybe Int -- ^ indent in this column + ,Maybe Align -- ^ alignment ) -- * Definitions of fields accessible at many stages @@ -61,6 +63,7 @@ . grouping getLine -- | Extract both line and column where a token starts. +getLineCol :: Field2 a a MyLoc MyLoc => a -> (Int, Int) getLineCol x = (getLine x, getCol x) -- | Mark alignment boundaries. @@ -73,14 +76,15 @@ . blocks . sortBy (compare `on` getLine) where - getLine (tok, MyLoc line col, _, _) = line + getLine (tok, MyLoc line col _, _, _) = line -- | If first indented token is yet unmarked, mark it as boundary. +-- FIXME: remove boundaries from not `mark`s. markIndent :: Aligned -> Aligned -markIndent (TBlank, myLoc@(MyLoc _ 1 ), txt, Just indent, _) = +markIndent (TBlank, myLoc@(MyLoc _ 1 _), txt, Just indent, _) = (TBlank, myLoc , txt, Just indent, Just AIndent) -markIndent (myTok, myLoc@(MyLoc _ col), txt, Just indent, _) | indent == col = - (myTok, myLoc , txt, Just indent, Just ALeft) +markIndent (myTok, myLoc@(MyLoc _ col True), txt, Just indent, _) | indent == col = + (myTok, myLoc , txt, Just indent, Just ALeft) markIndent other = other -- | Append alignment option to unanalyzed token record. @@ -91,12 +95,21 @@ -- check the alignment option that applies to this column. alignBlock :: [Unanalyzed] -> [Aligned] alignBlock [a] = withAlign Nothing <$> [a] -alignBlock opList | all isOperator opList = withAlign (Just ACenter) <$> opList +alignBlock opList | all isOperator (filter isMarked opList) = + withMarked (withAlign $ Just ACenter) opList where isOperator (TOperator, _, _, _) = True isOperator _ = False -alignBlock aList = withAlign (Just ALeft ) <$> aList + isMarked (_, MyLoc _ _ True, _, _) = True + isMarked (_, _, _, _) = False +alignBlock aList = + withMarked (withAlign $ Just ALeft ) aList +withMarked f aList = apply <$> aList + where + apply entry@(view _2 -> MyLoc _ _ True) = f entry + apply entry = entry `annex` Nothing + -- | Compute all alignment columns existing and their positions in the text column space. extraColumns :: Field2 a a MyLoc MyLoc => Field5 a a (Maybe Align) (Maybe Align) @@ -114,6 +127,7 @@ -- | Compute all alignment columns existing and their positions in the text column space. -- TEST: check that we always have correct number of columns +-- FIXME: known bug that may be caused by this one tableColumns :: Field2 a a MyLoc MyLoc => Field5 a a (Maybe b) (Maybe b) => [a] @@ -153,10 +167,11 @@ where indentColumn :: Maybe Int indentColumn = extractColumn $ filter notBlank aLine - notBlank (TBlank, _, _) = False - notBlank _ = True - extractColumn [] = Nothing - extractColumn ((_, MyLoc line col, _):_) = Just col + notBlank (TBlank, _, _) = False + notBlank _ = True + extractColumn [] = Nothing + extractColumn ((_, MyLoc line col _, _):_) = Just col + -- FIXME: is it only for `mark` columns? -- | Given a list of aligned records, and a list of marker columns, -- add table column indices to each record. diff --git a/src/Render/ColSpan.hs b/src/Render/ColSpan.hs --- a/src/Render/ColSpan.hs +++ b/src/Render/ColSpan.hs @@ -12,6 +12,7 @@ import Data.List(groupBy, sortBy) import Prelude hiding(getLine) import Optics.Core ( Field1(_1), Field2(_2), view, (%)) +import Control.Exception(assert) import Alignment ( textContent, tokenType, Align(ALeft), Processed ) @@ -44,10 +45,19 @@ where nextCol = getAlignCol $ head c getAlign :: Processed -> Align - getAlign = view (alignPos % maybeLens (ALeft, 0) % _1) + getAlign = view (alignPos % maybeLens (ALeft, 1) % _1) extractTokens (a,b,c) = (extractToken <$> a, b, c) extractToken tok = (view tokenType tok, view textContent tok) -- FIXME: split lines before colspans! + +numColSpans :: [Processed] -> Int +numColSpans ps = case colspansPerLine of + [] -> 1 + n:ns -> assert (all (n==) ns) + $ n + where + colspansPerLine :: [Int] + colspansPerLine = map (sum . map (\(_,c,_) -> c)) . colspans $ ps -- | Given a `Processed` record, extract number of table columns. getAlignCol :: Processed -> Int diff --git a/src/Render/Debug.hs b/src/Render/Debug.hs --- a/src/Render/Debug.hs +++ b/src/Render/Debug.hs @@ -5,12 +5,12 @@ {-# LANGUAGE FlexibleContexts #-} -- | Renders alignment to text with alignment markers, -- for debugging purposes. -module Render.Debug(render) where +module Render.Debug(render, renderInline) where import Data.Text (Text) import qualified Data.Text as T import Prelude hiding(getLine) -import Optics.Core ( view ) +import Optics.Core ( view, Field2(..)) import FindColumns ( alignPos, getCol, tableColumns ) import Alignment ( textContent, Align(..), Processed ) @@ -26,7 +26,7 @@ maybeInsertAt :: Int -> a -> [a] -> Maybe [a] maybeInsertAt 0 e ls = pure $ e:ls maybeInsertAt i e (l:ls) = (l:) <$> maybeInsertAt (i-1) e ls -maybeInsertAt i e [] = Nothing +maybeInsertAt _ _ [] = Nothing -- | Render text of code blocks -- with marker columns inserted @@ -49,7 +49,7 @@ alignMarker :: Text alignMarker = case view alignPos tok of Just (ACenter, _) -> "^" - Just (ALeft, _) -> "|" + Just _ -> "|" otherwise -> "" -- | Text content with markers for markers inside it. @@ -67,3 +67,6 @@ | otherwise = id columnsBetween :: Int -> Int -> [Int] columnsBetween colA colB = filter (\c -> c >= colA && c < colB) tColumns + +renderInline :: Field2 a a Text Text => [a] -> Text +renderInline = mconcat . map (view _2) diff --git a/src/Render/HTML.hs b/src/Render/HTML.hs --- a/src/Render/HTML.hs +++ b/src/Render/HTML.hs @@ -1,13 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | Render analyzed tokens into HTML table. -module Render.HTML(htmlFromColSpans) where +module Render.HTML(htmlFromColSpans, htmlInline) where import Prelude hiding(span, id) import Data.Text(Text) import qualified Data.Text as T import qualified Data.Text.Lazy as LT -import Text.Blaze.Html5 hiding(style) +import Text.Blaze.Html5 + ( toHtml, + Html, + ToValue(toValue), + (!), + b, + html, + i, + span, + table, + tbody, + td, + tr ) import Text.Blaze.Html5.Attributes(colspan, style, id) import Text.Blaze.Html.Renderer.Text(renderHtml) @@ -47,12 +59,18 @@ alignStyle = "text-align: " <> alignMark alignment alignMark ACenter = "center" alignMark ALeft = "left" + alignMark AIndent = "left" -- TODO: braced operators -- | Given a list of tokens in a colspan, render HTML fragment. +htmlInline :: [(MyTok, Text)] -> Text +htmlInline = LT.toStrict + . renderHtml + . formatTokens + formatTokens :: [(MyTok, Text)] -> Html -formatTokens = mapM_ formatToken - . preformatTokens +formatTokens = mapM_ formatToken + . preformatTokens -- | Format a single token as HTML fragment. formatToken :: (MyTok, Text) -> Html diff --git a/src/Render/Latex.hs b/src/Render/Latex.hs --- a/src/Render/Latex.hs +++ b/src/Render/Latex.hs @@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} -- | Render analyzed input into LaTeX table. -module Render.Latex(latexFromColSpans) where +module Render.Latex(latexFromColSpans, latexInline) where import Data.Text(Text) import qualified Data.Text as T import Text.LaTeX.Base.Syntax(protectText) -import Alignment +import Alignment ( Align(..) ) import Render.Common(TokensWithColSpan) import Token(MyTok(..)) import Util(unbrace) @@ -33,11 +33,12 @@ renderColSpan (toks, colSpan, alignment) = T.concat [ "\\multicolumn{", T.pack $ show colSpan , "}{", alignMark alignment - , "}{$", formatTokens toks + , "}{$", latexInline toks , "$}" ] where alignMark ACenter = "c" alignMark ALeft = "l" + alignMark AIndent = "l" -- | Wrap a LaTeX table content into \begin{tabular} environment. wrapTable :: Int -> Text -> Text @@ -46,7 +47,7 @@ -- ,"\\setlength{\\tabcolsepBACKUP}{\\tabcolsep}" "\\setlength{\\tabcolsep}{1pt}\n" , "\\begin{tabular}{" - , T.replicate (cols+3) "l" -- FIXME: tests for correct number of columns + , T.replicate (cols+1) "l" -- FIXME: tests for correct number of columns , "}\n" , txt, "\n\\end{tabular}" --,"\\setlength{\\tabcolsep}{\\tabcolsepBACKUP}" @@ -60,10 +61,11 @@ preformatTokens ((TOperator,"`"):(TVar, "elem"):(TOperator, "`"):rest) = (TOperator, "elem"):preformatTokens rest preformatTokens (a :rest) = a :preformatTokens rest + -- | Format a list of tokens within a colspan. -- Preprocesses then and calls `formatToken` for each. -formatTokens :: [(MyTok, Text)] -> Text -formatTokens = T.concat +latexInline :: [(MyTok, Text)] -> Text +latexInline = T.concat . fmap formatToken . preformatTokens -- . (\t -> trace ("Tokens: " <> show t) t) -- debug @@ -73,12 +75,13 @@ formatToken :: (MyTok, Text) -> Text formatToken (TOperator,unbrace -> Just op) = "(" <> formatToken (TOperator, op) <> ")" formatToken (TKeyword, "forall") = mathop "forall" -formatToken (TVar, "mempty") = mathop "emptyset" +--formatToken (TVar, "mempty") = mathop "emptyset" formatToken (TVar, "bottom") = mathop "bot" formatToken (TVar, "undefined") = mathop "perp" formatToken (TVar, "top" ) = mathop "top" formatToken (TVar, "not" ) = mathop "neg" -formatToken (TOperator,">>=" ) = mathop "mathbin{>\\!\\!\\!>\\!\\!=}" -- from lhs2TeX, Neil Mitchell's +--formatToken (TOperator,">>=" ) = mathop "mathbin{>\\!\\!\\!>\\!\\!=}" -- from lhs2TeX, Neil Mitchell's +formatToken (TOperator,">>=" ) = mathop "mathbin{\\gg\\!\\!=}" -- from lhs2TeX, Neil Mitchell's formatToken (TOperator,"=<<" ) = mathop "mathbin{=\\!\\!<\\!\\!\\!<}" -- from lhs2TeX, Neil Mitchell's formatToken (TOperator,">=>" ) = mathop "mathbin{>\\!\\!=\\!\\!\\!>}" formatToken (TOperator,"|-" ) = mathop "vdash" @@ -92,21 +95,24 @@ formatToken (TOperator,"|" ) = mathop "vert" formatToken (TOperator,"||" ) = mathop "parallel" formatToken (TOperator,"|>" ) = mathop "triangleright" -formatToken (TOperator,">>" ) = mathop "mathbin{>\\!\\!\\!>}" -- gg -formatToken (TOperator,">>>" ) = mathop "mathbin{>\\!\\!\\!>\\!\\!\\!>}" -- gg +--formatToken (TOperator,">>" ) = mathop "mathbin{>\\!\\!\\!>}" -- gg +--formatToken (TOperator,">>>" ) = mathop "mathbin{>\\!\\!\\!>\\!\\!\\!>}" -- gg formatToken (TOperator,">>" ) = mathop "gg" formatToken (TOperator,">>>" ) = mathop "ggg" formatToken (TOperator,"<<" ) = mathop "ll" formatToken (TOperator,"<<<" ) = mathop "lll" -formatToken (TOperator,"-<" ) = mathop "prec" +--formatToken (TOperator,"-<" ) = mathop "prec" +formatToken (TOther, "-<" ) = mathop "prec" +formatToken (TOther, ">-" ) = mathop "succ" formatToken (TOperator,"\\\\" ) = mathop "setminus" -formatToken (TOperator,"<-" ) = mathop "gets" +formatToken (TOther ,"<-" ) = mathop "gets" formatToken (TOperator,">=" ) = mathop "geq" formatToken (TOperator,"<=" ) = mathop "leq" formatToken (TOperator,"!=" ) = mathop "ne" formatToken (TOperator,"<->" ) = mathop "leftrightarrow" -formatToken (TOperator,"->" ) = mathop "to" -formatToken (TOperator,"=>" ) = mathop "Rightarrow" +--formatToken (TOperator,"->" ) = mathop "to" +formatToken (TOther, "->" ) = mathop "to" +formatToken (TOther, "=>" ) = mathop "Rightarrow" formatToken (TOperator,"==>" ) = mathop "implies" formatToken (TOperator,"|->" ) = mathop "mapsto" --formatToken (TOperator,"|=>" ) = mathop "Mapsto" -- not in amssymb @@ -127,8 +133,20 @@ formatToken (TCons, cons ) = "\\textsc{" <> protectText cons <> "}" formatToken (TOperator,"\\" ) = mathop "lambda" formatToken (TTikz mark,_ ) = mathop $ "tikzMark{" <> mark <> "}" +--formatToken (TOther, "`" ) = mathop "textasciigrave" +formatToken (TOther, "`" ) = protectText "`" +formatToken (TOther, "'" ) = mathop "prime" +formatToken (TOther, "\"" ) = protectText "\"" +formatToken (TOther, "(" ) = protectText "(" +formatToken (TOther, ")" ) = protectText ")" +formatToken (TOther, "]" ) = protectText "]" +formatToken (TOther, "[" ) = protectText "[" +formatToken (TOther, "}" ) = protectText "}" +formatToken (TOther, "{" ) = protectText "{" formatToken (_, txt ) = "\\textit{" <> protectText txt <> "}" +mathop :: Text -> Text mathop code = "\\" <> code +prologue :: Text prologue = T.concat ["\\usepackage{amssymb}"] diff --git a/src/Token.hs b/src/Token.hs --- a/src/Token.hs +++ b/src/Token.hs @@ -4,19 +4,18 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -- | Common token representation used. -module Token(MyTok(..), MyLoc(..), Tokenized, line, col, unwrap, unTikzMark) where +module Token(MyTok(..), MyLoc(..), Tokenized, line, col, mark, unwrap, unTikzMark) where -import Data.Maybe(fromMaybe) import Data.Text(Text) import qualified Data.Text as T -import Data.Tuple.Optics import Optics.TH -- * Common tokens and locations -- We keep them here, so we can translate output from tokenizers to common format. -- | Location is just line and column (not a slice.) -data MyLoc = MyLoc { _line :: Int -- ^ Line number starting from 1 - , _col :: Int -- ^ Column number starting from 1 +data MyLoc = MyLoc { _line :: Int -- ^ Line number starting from 1 + , _col :: Int -- ^ Column number starting from 1 + , _mark :: Bool -- ^ Is this a valid indent mark? } deriving (Eq, Ord, Show) @@ -35,14 +34,17 @@ deriving (Eq, Ord, Show) -- | Records tokenized and converted to common token format. -type Tokenized = (MyTok, MyLoc, Text) +type Tokenized = (MyTok -- ^ Token type + ,MyLoc -- ^ Starting location for the token + ,Text -- ^ text value of the token + ) -- | Unpack a Haskell comment with a TikZ mark indicator. unTikzMark :: Text -> Maybe Text unTikzMark txt = unwrap "{->" "-}" txt >>= \case - "" -> Nothing - mark -> Just mark + "" -> Nothing + aMark -> Just aMark -- | Given opening text, and closing text, -- check that input is "braced" by these, and strip them. diff --git a/src/Token/Haskell.hs b/src/Token/Haskell.hs --- a/src/Token/Haskell.hs +++ b/src/Token/Haskell.hs @@ -1,24 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} -- | Haskell code tokenizer module Token.Haskell(tokenizer) where -import Control.Arrow(first) -import Text.Pandoc.JSON +import Text.Pandoc.JSON () import Text.Pandoc.Definition () -import Data.Function(on) -import Data.Maybe(fromMaybe, isJust) -import Data.String (fromString, IsString) +import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T -import Data.List(groupBy, sortBy) -import Debug.Trace(trace) import Prelude hiding(getLine) +import Optics.Core import GHC.SyntaxHighlighter + ( tokenizeHaskell + , Loc(..) + , Token(..) ) -import Token +import Token ( MyLoc(MyLoc), MyTok(..), unTikzMark, mark ) -- * Haskell tokenizer frontend -- | Attempt to tokenize input, @@ -36,12 +36,14 @@ -- | Recognize token using both token type from `ghc-lib`, -- and text content. -- Only TikZ marks are recognized by looking up text content. +recognizeToken :: (Token, Text) -> (MyTok, Text) recognizeToken (CommentTok, tokText@(unTikzMark -> Just mark)) = (TTikz mark, tokText) recognizeToken (tokType, tokText) = (haskellTok tokType, tokText) -- | Convert token type of `ghc-lib` into tokens recognized by the filter. +haskellTok :: Token -> MyTok haskellTok SpaceTok = TBlank haskellTok CommentTok = TBlank haskellTok PragmaTok = TBlank @@ -54,49 +56,27 @@ haskellTok t = TOther -- | Extract line number from `ghc-lib` slice location. +locLine :: Loc -> Int locLine (Loc startLineNo startColNo _ _) = startLineNo -- | Extract column number from `ghc-lib` slice location. +locCol :: Loc -> Int locCol (Loc startLineNo startColNo _ _) = startColNo --- | Split tokens into one blank per line. --- TESTME: assures that no token has '\n' before the end of text. -splitTokens :: [(MyTok, MyLoc, Text)] -> [(MyTok, MyLoc, Text)] -splitTokens = mconcat - . fmap splitter - where - splitter :: (MyTok, MyLoc, Text) -> [(MyTok, MyLoc, Text)] - splitter (TBlank, loc@(MyLoc line _), txt) | T.filter (=='\n') txt /= "" = - withLocs withNewLines - where - split, withNewLines :: [Text] - split = T.lines txt - withNewLines = fmap (<>"\n") (init split) - <> [last split] - withLocs :: [Text] -> [(MyTok, MyLoc, Text)] - withLocs (l:ls) = (TBlank, loc, l) - : zipWith mkEntry [line+1..] ls - mkEntry :: Int -> Text -> (MyTok, MyLoc, Text) - mkEntry i t = (TBlank, MyLoc i 1, t) - splitter other = [other] - -joinEscapedOperators ((TOperator, loc, "("):(TOperator, _, op):(TOperator, _, ")"):rest) = - (TOperator, loc, "(" <> op <> ")"):joinEscapedOperators rest -joinEscapedOperators (tok:rest) = tok:joinEscapedOperators rest -joinEscapedOperators [] = [] - -- | Restore locations -- TESTME: test -- 1. Without newlines should return a list of indices up to length -- 2. Of the same length as number of tokens -- 3. With newlines should return line indices up to number of lines. -- 4. Same for a list of lists of words without newlines joined as lines -restoreLocations :: [(a, Text)] -> [(a, MyLoc, Text)] +restoreLocations :: [(MyTok, Text)] -> [(MyTok, MyLoc, Text)] restoreLocations = go 1 1 where go line col [] = [] go line col ((tok, txt):ls) = - (tok, MyLoc line col, txt):go newLine newCol ls + (tok, MyLoc line col (isMark tok), txt):go newLine newCol ls where + isMark TBlank = False + isMark _ = True newLine = line + lineIncr lineIncr = T.length $ T.filter (=='\n') txt newCol | lineIncr == 0 = col + T.length txt @@ -105,4 +85,44 @@ $ fst $ T.break (=='\n') $ T.reverse txt + +-- * Likely common with other tokenizers +-- | Split tokens into one blank per line. +-- TESTME: assures that no token has '\n' before the end of text. +splitTokens :: [(MyTok, MyLoc, Text)] -> [(MyTok, MyLoc, Text)] +splitTokens = mconcat + . fmap splitter + where + splitter :: (MyTok, MyLoc, Text) -> [(MyTok, MyLoc, Text)] + splitter (TBlank, loc@(MyLoc line _ _), txt) | T.filter (=='\n') txt /= "" = + withLocs withNewLines + where + split, withNewLines :: [Text] + split = T.lines txt + withNewLines = fmap (<>"\n") (init split) + <> [last split] + withLocs :: [Text] -> [(MyTok, MyLoc, Text)] + withLocs (l:ls) = (TBlank, set mark True $ loc, l) + : zipWith mkEntry [line+1..] ls + mkEntry :: Int -> Text -> (MyTok, MyLoc, Text) + mkEntry i t = (TBlank, MyLoc i 1 True, t) + splitter other@(_, loc@(MyLoc line 1 x), txt) = [set (_2 % mark) True other] + splitter other = [other] + + +unmark :: Field2 a a MyLoc MyLoc => a -> a +unmark = set (_2 % mark) False + +-- FIXME: use no-indent-mark instead. +joinEscapedOperators :: (Eq c, IsString c, Semigroup c) => [(MyTok, MyLoc, c)] -> [(MyTok, MyLoc, c)] +joinEscapedOperators (a@(_, _, "("):b@(_, _, _):c@(_, _, ")"):rest) = + a:unmark b:unmark c:joinEscapedOperators rest +joinEscapedOperators (a@(_, loc, "`"):b@(_, _, _):c@(_, _, "`"):rest) = + a:unmark b:unmark c:joinEscapedOperators rest +joinEscapedOperators (a@(_, _, "("):b@(TOperator, _, _):rest) = + a:unmark b:joinEscapedOperators rest +joinEscapedOperators (a@(_, _, _):b@(_, _, ")"):rest) = + a:unmark b:joinEscapedOperators rest +joinEscapedOperators (tok:rest) = tok:joinEscapedOperators rest +joinEscapedOperators [] = [] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Test suite +module Main where + +import Data.Text.Arbitrary +import Test.QuickCheck +import qualified Data.Text as T +import Data.Char +import Optics.Core (view, Field1(_1)) + + +import Token(MyTok(..) + ,MyLoc(..) + ,Tokenized) +import Token.Haskell(tokenizer) +import qualified Render.Debug +import FindColumns +import Render.ColSpan +import Alignment(Processed) + +prop_tokenizer str = case tokenizer str of + Nothing -> label "cannot lex" $ True + Just t -> label "lexed" $ length t <= T.length str + +prop_debug_renderer_text_length input = + case debug of + Nothing -> label "cannot lex" $ True + Just t -> label "lexed" + $ all (uncurry (<=)) + $ zip (extract input) + (extract t) + where + extract :: T.Text -> [Int] + extract = fmap T.length . T.lines + debug :: Maybe T.Text + debug = tokenizer input >>= (return . Render.Debug.render . findColumns) + +prop_colspans input = + case debug of + Nothing -> label "cannot lex" $ True + Just t -> label "lexed" $ + sameNumber t + where + extract :: T.Text -> [Int] + extract = fmap T.length . T.lines + debug :: Maybe [Int] + debug = tokenizer input >>= (return . sumColSpans . findColumns) + sameNumber [] = True + sameNumber (n:ns) = all (n==) ns + +prop_tableColumns input = T.any (not . Data.Char.isSpace) input ==> + case tokenizer input of + Nothing -> label "cannot lex" $ True + Just tokens | all ((TBlank==) . view _1) tokens + -> label "only blanks" $ True + Just tokens -> + case findColumns tokens of + [] -> label "empty" $ True + t -> case sumColSpans t of + [] -> label "no colspans" $ True + c:_ -> label "tableColumns" $ c == length (tableColumns t) + where + extract :: T.Text -> [Int] + extract = fmap T.length . T.lines + debug :: Maybe [Processed] + debug = tokenizer input >>= (return . findColumns) + sameNumber [] = True + sameNumber (n:ns) = all (n==) ns + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = do + problem " a\na" + problem "--" + problem "a\n a" + quickCheck prop_tokenizer + quickCheck prop_debug_renderer_text_length + quickCheck $ withMaxSuccess 10000 prop_colspans -- is it sufficient? + quickCheck $ withMaxSuccess 100000 prop_tableColumns -- is it sufficient? + where + problem example = do + putStrLn $ "Example: " <> show example + print $ tokenizer example >>= (return . tableColumns . findColumns) + print $ tokenizer example >>= (return . sumColSpans . findColumns) + print $ tokenizer example >>= (return . findColumns) + print $ tokenizer example + +sumColSpans = map (sum . map (\(_,c,_) -> c)) . colspans +