diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for commonmark-initial + +## 0.1.0.0 -- 2025-07-28 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2025 Henry Till + +Permission to use, copy, modify, and/or distribute this software for any purpose +with or without fee is hereby granted, provided that the above copyright notice +and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +THIS SOFTWARE. diff --git a/commonmark-initial.cabal b/commonmark-initial.cabal new file mode 100644 --- /dev/null +++ b/commonmark-initial.cabal @@ -0,0 +1,53 @@ +cabal-version: 3.0 +name: commonmark-initial +version: 0.1.0.0 +synopsis: An initial encoding of the CommonMark language +description: + This library provides an initial encoding of the CommonMark language + for use with the [commonmark](https://hackage.haskell.org/package/commonmark) + library. +license: ISC +license-file: LICENSE +author: Henry Till +maintainer: henrytill@gmail.com +homepage: https://github.com/henrytill/commonmark-initial +copyright: Copyright (c) 2025, Henry Till +category: Text +build-type: Simple +extra-doc-files: CHANGELOG.md +tested-with: GHC ==9.4.8 || ==9.6.7 || ==9.8.4 || ==9.10.2 || ==9.12.2 + +source-repository head + type: git + location: https://github.com/henrytill/commonmark-initial.git + +common warnings + ghc-options: -Wall + +library + import: warnings + default-language: GHC2021 + hs-source-dirs: src + exposed-modules: Commonmark.Initial + build-depends: + base >=4.17.2.1 && <4.22, + commonmark ^>=0.2.6.1, + deriving-compat ^>=0.6.7, + free ^>=5.2, + text >=2.0.2 && <2.2 + +test-suite commonmark-initial-test + import: warnings + default-language: GHC2021 + hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Commonmark.InitialTest + build-depends: + base >=4.17.2.1 && <4.22, + commonmark ^>=0.2.6.1, + commonmark-extensions ^>=0.2.6, + dwergaz ^>=0.3.1.0, + parsec ^>=3.1.16.1, + text >=2.0.2 && <2.2, + commonmark-initial diff --git a/src/Commonmark/Initial.hs b/src/Commonmark/Initial.hs new file mode 100644 --- /dev/null +++ b/src/Commonmark/Initial.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Commonmark.Initial + ( Ann (..) + , Block + , Blocks + , BlockF (..) + , Inline + , Inlines + , InlineF (..) + , pattern MkBlock + , pattern MkInline + ) +where + +import Commonmark.Types + ( Attributes + , Format + , HasAttributes (..) + , IsBlock (..) + , IsInline (..) + , ListSpacing + , ListType + , Rangeable (..) + , SourceRange + ) +import Control.Comonad.Cofree +import Data.Eq.Deriving +import Data.Text (Text) +import Text.Show.Deriving + +data Ann = MkAnn + { range :: SourceRange + , attributes :: Attributes + } + deriving (Show, Eq) + +instance Semigroup Ann where + a <> b = MkAnn (a.range <> b.range) (a.attributes <> b.attributes) + +instance Monoid Ann where + mempty = MkAnn mempty mempty + +data InlineF r + = LineBreak + | SoftBreak + | Str Text + | Entity Text + | EscapedChar Char + | Emph [r] + | Strong [r] + | Link Text Text [r] + | Image Text Text [r] + | Code Text + | RawInline Format Text + deriving (Show, Eq, Functor, Foldable, Traversable) + +$(deriveShow1 ''InlineF) +$(deriveEq1 ''InlineF) + +type Inline a = Cofree InlineF a + +pattern MkInline :: a -> InlineF (Inline a) -> Inline a +pattern MkInline a body = a :< body + +{-# COMPLETE MkInline #-} + +type Inlines = [Inline Ann] + +rangedInline :: SourceRange -> Inline Ann -> Inline Ann +rangedInline sr (MkInline ann body) = MkInline (ann <> MkAnn sr mempty) body + +addAttributesInline :: Attributes -> Inline Ann -> Inline Ann +addAttributesInline attrs (MkInline ann body) = MkInline (ann <> MkAnn mempty attrs) body + +instance Rangeable Inlines where + ranged sr = map $ rangedInline sr + +instance HasAttributes Inlines where + addAttributes attrs = map $ addAttributesInline attrs + +mkInline :: (Monoid a) => InlineF (Inline a) -> Inline a +mkInline = MkInline mempty + +instance IsInline Inlines where + lineBreak = [mkInline LineBreak] + softBreak = [mkInline SoftBreak] + str t = [mkInline $ Str t] + entity t = [mkInline $ Entity t] + escapedChar c = [mkInline $ EscapedChar c] + emph ils = [mkInline $ Emph ils] + strong ils = [mkInline $ Strong ils] + link d t desc = [mkInline $ Link d t desc] + image s t desc = [mkInline $ Image s t desc] + code t = [mkInline $ Code t] + rawInline f t = [mkInline $ RawInline f t] + +data BlockF a r + = Paragraph [Inline a] + | Plain [Inline a] + | ThematicBreak + | BlockQuote [r] + | CodeBlock Text Text + | Heading Int [Inline a] + | RawBlock Format Text + | ReferenceLinkDefinition Text (Text, Text) + | List ListType ListSpacing [[r]] + deriving (Show, Eq, Functor, Foldable, Traversable) + +$(deriveShow1 ''BlockF) +$(deriveEq1 ''BlockF) + +type Block a = Cofree (BlockF a) a + +pattern MkBlock :: a -> BlockF a (Block a) -> Block a +pattern MkBlock a body = a :< body + +{-# COMPLETE MkBlock #-} + +type Blocks = [Block Ann] + +rangedBlock :: SourceRange -> Block Ann -> Block Ann +rangedBlock sr (MkBlock ann body) = MkBlock (ann <> MkAnn sr mempty) body + +addAttributesBlock :: Attributes -> Block Ann -> Block Ann +addAttributesBlock attrs (MkBlock ann body) = MkBlock (ann <> MkAnn mempty attrs) body + +instance Rangeable Blocks where + ranged sr = map $ rangedBlock sr + +instance HasAttributes Blocks where + addAttributes attrs = map $ addAttributesBlock attrs + +mkBlock :: (Monoid a) => BlockF a (Block a) -> Block a +mkBlock = MkBlock mempty + +instance IsBlock Inlines Blocks where + paragraph ils = [mkBlock $ Paragraph ils] + plain ils = [mkBlock $ Plain ils] + thematicBreak = [mkBlock ThematicBreak] + blockQuote bs = [mkBlock $ BlockQuote bs] + codeBlock info c = [mkBlock $ CodeBlock info c] + heading level ils = [mkBlock $ Heading level ils] + rawBlock f t = [mkBlock $ RawBlock f t] + referenceLinkDefinition l dt = [mkBlock $ ReferenceLinkDefinition l dt] + list lt ls bss = [mkBlock $ List lt ls bss] diff --git a/test/Commonmark/InitialTest.hs b/test/Commonmark/InitialTest.hs new file mode 100644 --- /dev/null +++ b/test/Commonmark/InitialTest.hs @@ -0,0 +1,559 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Commonmark.InitialTest where + +import Commonmark +import Commonmark.Extensions.Attributes (attributesSpec) +import Commonmark.Initial +import Data.Functor.Identity (runIdentity) +import Data.Text (Text) +import Data.Text qualified as Text +import Test.Dwergaz +import Text.Parsec.Pos (newPos) + +myCommonmark :: (IsBlock il bl) => String -> Text -> Either ParseError bl +myCommonmark name = runIdentity . commonmarkWith (defaultSyntaxSpec <> attributesSpec) name + +parseName :: String +parseName = "test" + +parse :: Text -> Either ParseError Blocks +parse = myCommonmark parseName + +testHeading :: Test +testHeading = assertEqual "Test Heading" expected actual + where + actual = parse $ Text.unlines ["# Hello, world!"] + expected = + Right + [ MkBlock + ( MkAnn + { range = SourceRange [(newPos parseName 1 1, newPos parseName 2 1)] + , attributes = [] + } + ) + ( Heading + 1 + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 3, newPos parseName 1 8)] + , attributes = [] + } + ) + (Str "Hello") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 8, newPos parseName 1 9)] + , attributes = [] + } + ) + (Str ",") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 9, newPos parseName 1 10)] + , attributes = [] + } + ) + (Str " ") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 10, newPos parseName 1 15)] + , attributes = [] + } + ) + (Str "world") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 15, newPos parseName 1 16)] + , attributes = [] + } + ) + (Str "!") + ] + ) + ] + +testHeadingAttributes :: Test +testHeadingAttributes = assertEqual "Test Heading w/attributes" expected actual + where + actual = parse $ Text.unlines ["# Hello, world! {#foo}"] + expected = + Right + [ MkBlock + ( MkAnn + { range = SourceRange [(newPos parseName 1 1, newPos parseName 2 1)] + , attributes = [("id", "foo")] + } + ) + ( Heading + 1 + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 3, newPos parseName 1 8)] + , attributes = [] + } + ) + (Str "Hello") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 8, newPos parseName 1 9)] + , attributes = [] + } + ) + (Str ",") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 9, newPos parseName 1 10)] + , attributes = [] + } + ) + (Str " ") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 10, newPos parseName 1 15)] + , attributes = [] + } + ) + (Str "world") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 15, newPos parseName 1 16)] + , attributes = [] + } + ) + (Str "!") + ] + ) + ] + +testParagraph :: Test +testParagraph = assertEqual "Test Paragraph" expected actual + where + actual = parse $ Text.unlines ["Hello, world!"] + expected = + Right + [ MkBlock + ( MkAnn + { range = SourceRange [(newPos parseName 1 1, newPos parseName 2 1)] + , attributes = [] + } + ) + ( Paragraph + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 1, newPos parseName 1 6)] + , attributes = [] + } + ) + (Str "Hello") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 6, newPos parseName 1 7)] + , attributes = [] + } + ) + (Str ",") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 7, newPos parseName 1 8)] + , attributes = [] + } + ) + (Str " ") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 8, newPos parseName 1 13)] + , attributes = [] + } + ) + (Str "world") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 13, newPos parseName 1 14)] + , attributes = [] + } + ) + (Str "!") + ] + ) + ] + +testDocument :: Test +testDocument = assertEqual "Test Document" expected actual + where + actual = + parse $ + Text.unlines + [ "# Hello, world! {#foo}" + , "" + , "Hello, world!" + ] + expected = + Right + [ MkBlock + ( MkAnn + { range = SourceRange [(newPos parseName 1 1, newPos parseName 2 1)] + , attributes = [("id", "foo")] + } + ) + ( Heading + 1 + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 3, newPos parseName 1 8)] + , attributes = [] + } + ) + (Str "Hello") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 8, newPos parseName 1 9)] + , attributes = [] + } + ) + (Str ",") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 9, newPos parseName 1 10)] + , attributes = [] + } + ) + (Str " ") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 10, newPos parseName 1 15)] + , attributes = [] + } + ) + (Str "world") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 15, newPos parseName 1 16)] + , attributes = [] + } + ) + (Str "!") + ] + ) + , MkBlock + ( MkAnn + { range = SourceRange [(newPos parseName 3 1, newPos parseName 4 1)] + , attributes = [] + } + ) + ( Paragraph + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 3 1, newPos parseName 3 6)] + , attributes = [] + } + ) + (Str "Hello") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 3 6, newPos parseName 3 7)] + , attributes = [] + } + ) + (Str ",") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 3 7, newPos parseName 3 8)] + , attributes = [] + } + ) + (Str " ") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 3 8, newPos parseName 3 13)] + , attributes = [] + } + ) + (Str "world") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 3 13, newPos parseName 3 14)] + , attributes = [] + } + ) + (Str "!") + ] + ) + ] + +testList :: Test +testList = assertEqual "Test List" expected actual + where + actual = + parse $ + Text.unlines + [ "- Hello, world!" + , "- Goobye" + , "" + , " Again" + ] + expected = + Right + [ MkBlock + ( MkAnn + { range = SourceRange [(newPos parseName 1 1, newPos parseName 5 1)] + , attributes = [] + } + ) + ( List + (BulletList '-') + LooseList + [ + [ MkBlock + ( MkAnn + { range = + SourceRange + [ (newPos parseName 1 3, newPos parseName 2 1) + , (newPos parseName 1 1, newPos parseName 2 1) + ] + , attributes = [] + } + ) + ( Paragraph + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 3, newPos parseName 1 8)] + , attributes = [] + } + ) + (Str "Hello") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 8, newPos parseName 1 9)] + , attributes = [] + } + ) + (Str ",") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 9, newPos parseName 1 10)] + , attributes = [] + } + ) + (Str " ") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 10, newPos parseName 1 15)] + , attributes = [] + } + ) + (Str "world") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 15, newPos parseName 1 16)] + , attributes = [] + } + ) + (Str "!") + ] + ) + ] + , + [ MkBlock + ( MkAnn + { range = + SourceRange + [ (newPos parseName 2 3, newPos parseName 3 1) + , (newPos parseName 2 1, newPos parseName 5 1) + ] + , attributes = [] + } + ) + ( Paragraph + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 2 3, newPos parseName 2 9)] + , attributes = [] + } + ) + (Str "Goobye") + ] + ) + , MkBlock + ( MkAnn + { range = + SourceRange + [ (newPos parseName 4 3, newPos parseName 5 1) + , (newPos parseName 2 1, newPos parseName 5 1) + ] + , attributes = [] + } + ) + ( Paragraph + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 4 3, newPos parseName 4 8)] + , attributes = [] + } + ) + (Str "Again") + ] + ) + ] + ] + ) + ] + +testTightList :: Test +testTightList = assertEqual "Test Tight List" expected actual + where + actual = + parse $ + Text.unlines + [ "- Hello, world!" + , "- [Foo{#bar .klass baz=\"quux\"} is foo](https://www.foo.com/)" + ] + expected = + Right + [ MkBlock + ( MkAnn + { range = SourceRange [(newPos parseName 1 1, newPos parseName 3 1)] + , attributes = [] + } + ) + ( List + (BulletList '-') + TightList + [ + [ MkBlock + ( MkAnn + { range = + SourceRange + [ (newPos parseName 1 3, newPos parseName 2 1) + , (newPos parseName 1 1, newPos parseName 2 1) + ] + , attributes = [] + } + ) + ( Plain + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 3, newPos parseName 1 8)] + , attributes = [] + } + ) + (Str "Hello") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 8, newPos parseName 1 9)] + , attributes = [] + } + ) + (Str ",") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 9, newPos parseName 1 10)] + , attributes = [] + } + ) + (Str " ") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 10, newPos parseName 1 15)] + , attributes = [] + } + ) + (Str "world") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 1 15, newPos parseName 1 16)] + , attributes = [] + } + ) + (Str "!") + ] + ) + ] + , + [ MkBlock + ( MkAnn + { range = + SourceRange + [ (newPos parseName 2 3, newPos parseName 3 1) + , (newPos parseName 2 1, newPos parseName 3 1) + ] + , attributes = [] + } + ) + ( Plain + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 2 3, newPos parseName 2 61)] + , attributes = [] + } + ) + ( Link + "https://www.foo.com/" + mempty + [ MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 2 4, newPos parseName 2 7)] + , attributes = + [ ("id", "bar") + , ("class", "klass") + , ("baz", "quux") + ] + } + ) + (Str "Foo") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 2 31, newPos parseName 2 32)] + , attributes = [] + } + ) + (Str " ") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 2 32, newPos parseName 2 34)] + , attributes = [] + } + ) + (Str "is") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 2 34, newPos parseName 2 35)] + , attributes = [] + } + ) + (Str " ") + , MkInline + ( MkAnn + { range = SourceRange [(newPos parseName 2 35, newPos parseName 2 38)] + , attributes = [] + } + ) + (Str "foo") + ] + ) + ] + ) + ] + ] + ) + ] + +allTests :: Test +allTests = + group + "Commonmark.Initial tests" + [ testHeading + , testHeadingAttributes + , testParagraph + , testDocument + , testList + , testTightList + ] + +results :: (String, Bool) +results = (buildString mempty, allPassed) + where + result = runTest allTests + allPassed = resultIsPassed result + showResults = showString $ resultToString result + buildString = showResults . showChar '\n' diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,13 @@ +module Main (main) where + +import Commonmark.InitialTest qualified as InitialTest +import Control.Monad (unless) +import System.Exit (exitFailure) +import Text.Printf (printf) + +main :: IO () +main = do + let (initialOutput, initialPassed) = InitialTest.results + putStr initialOutput + printf "Summary: %s\n" (if initialPassed then "All tests passed!" else "Some tests failed.") + unless initialPassed exitFailure