├── Hakyll └── Web │ └── Agda.hs ├── LICENSE ├── Setup.hs ├── css └── agda.css ├── default.nix ├── hakyll-agda.cabal └── stack.yaml /Hakyll/Web/Agda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | -- Parts of the code (specifically parts of `pairPositions' and `groupLiterate') 4 | -- are taken from the Agda.Interaction.Highlighting.HTML module of Agda, see 5 | -- for the license and the copyright 6 | -- information for that code. 7 | module Hakyll.Web.Agda 8 | ( markdownAgda 9 | , pandocAgdaCompilerWithTransformM 10 | , pandocAgdaCompilerWith 11 | , pandocAgdaCompiler 12 | , isAgda 13 | , agdaPandocCompiler 14 | ) where 15 | 16 | import Agda.Interaction.FindFile (findFile, SourceFile(..)) 17 | import Agda.Interaction.Highlighting.Precise 18 | import qualified Agda.Interaction.Imports as Imp 19 | import Agda.Interaction.Options 20 | import Agda.Syntax.Abstract.Name (toTopLevelModuleName) 21 | import Agda.Syntax.Common 22 | import Agda.Syntax.Concrete.Name (TopLevelModuleName) 23 | import Agda.TypeChecking.Errors 24 | import Agda.TypeChecking.Monad (TCM) 25 | import qualified Agda.TypeChecking.Monad as TCM 26 | import Agda.Utils.FileName 27 | import qualified Agda.Utils.IO.UTF8 as UTF8 28 | import Control.Monad.Except (catchError, throwError) 29 | import Control.Monad.IO.Class (liftIO) 30 | import Data.Char (isSpace) 31 | import Data.Function (on) 32 | import qualified Data.IntMap as IntMap 33 | import Data.List (groupBy, isInfixOf, isPrefixOf, tails) 34 | import Data.Maybe (fromMaybe) 35 | import qualified Data.Set as Set 36 | import Data.Text.Lazy (Text) 37 | import qualified Data.Text.Lazy as TL 38 | import Hakyll.Core.Compiler 39 | import Hakyll.Core.Identifier 40 | import Hakyll.Core.Item 41 | import Hakyll.Core.Compiler.Internal 42 | import Hakyll.Web.Pandoc 43 | import System.Directory (getCurrentDirectory, setCurrentDirectory, canonicalizePath, setCurrentDirectory) 44 | import System.Exit (exitFailure) 45 | import System.FilePath (dropFileName, splitExtension) 46 | import Text.Pandoc (readMarkdown, ReaderOptions, WriterOptions, Pandoc) 47 | import qualified Text.Pandoc as Pandoc 48 | import Text.XHtml.Strict 49 | import qualified Data.Text as T 50 | 51 | checkFile :: SourceFile -> TCM TopLevelModuleName 52 | checkFile file = do 53 | TCM.resetState 54 | info <- Imp.sourceInfo file 55 | toTopLevelModuleName . TCM.iModuleName . fst <$> 56 | Imp.typeCheckMain file Imp.TypeCheck info 57 | 58 | getModule :: TopLevelModuleName -> TCM (HighlightingInfo, Text) 59 | getModule m = do 60 | Just mi <- TCM.getVisitedModule m 61 | f <- findFile m 62 | s <- liftIO . UTF8.readTextFile . filePath . srcFilePath $ f 63 | return (TCM.iHighlighting (TCM.miInterface mi), s) 64 | 65 | pairPositions :: HighlightingInfo -> String -> [(Integer, String, Aspects)] 66 | pairPositions info contents = 67 | map (\cs@((mi, (pos, _)) : _) -> (toInteger pos, map (snd . snd) cs, maybe mempty id mi)) $ 68 | groupBy ((==) `on` fst) $ 69 | map (\(pos, c) -> (IntMap.lookup pos infoMap, (pos, c))) $ 70 | zip [1..] $ 71 | contents 72 | where 73 | infoMap = toMap (decompress info) 74 | 75 | -- TODO make these more accurate 76 | beginCode :: String -> Bool 77 | beginCode s = "\\begin{code}" `isInfixOf` s 78 | 79 | endCode :: String -> Bool 80 | endCode s = "\\end{code}" `isInfixOf` s 81 | 82 | infixEnd :: Eq a => [a] -> [a] -> [a] 83 | infixEnd i s = head [drop (length i) s' | s' <- tails s, i `isPrefixOf` s'] 84 | 85 | stripBegin :: (Integer, String, Aspects) -> (Integer, String, Aspects) 86 | stripBegin (i, s, mi) = (i, cut (dropWhile (== ' ') (infixEnd "\\begin{code}" s)), mi) 87 | where 88 | cut ('\n' : s') = s' 89 | cut s' = s' 90 | 91 | groupLiterate 92 | :: [(Integer, String, Aspects)] 93 | -> [Either String [(Integer, String, Aspects)]] 94 | groupLiterate contents = 95 | let (com, rest) = span (notCode beginCode) contents 96 | in Left ("\n\n" ++ concat [s | (_, s, _) <- com] ++ "\n\n") : go rest 97 | where 98 | go [] = [] 99 | go (be : mis) = 100 | let be'@(_, s, _) = stripBegin be 101 | (code, rest) = span (notCode endCode) mis 102 | in if "\\end{code}" `isInfixOf` s 103 | then -- We simply ignore empty code blocks 104 | groupLiterate mis 105 | else Right (be' : code) : 106 | -- If there's nothing between \end{code} and \begin{code}, we 107 | -- start consuming code again. 108 | case rest of 109 | [] -> error "malformed file" 110 | ((_, beginCode -> True, _) : code') -> go code' 111 | (_ : com ) -> groupLiterate com 112 | 113 | notCode f (_, s, _) = not (f s) 114 | 115 | annotate :: TopLevelModuleName -> Integer -> Aspects -> Html -> Html 116 | annotate m pos mi = anchor ! attributes 117 | where 118 | attributes = [name (show pos)] ++ 119 | fromMaybe [] (definitionSite mi >>= link) ++ 120 | (case classes of [] -> []; cs -> [theclass (unwords cs)]) 121 | 122 | classes = maybe [] noteClasses (note mi) ++ 123 | otherAspectClasses (otherAspects mi) ++ 124 | maybe [] aspectClasses (aspect mi) 125 | 126 | aspectClasses (Name mKind op) = 127 | let kindClass = maybe [] ((: []) . showKind) mKind 128 | 129 | showKind (Constructor Inductive) = "InductiveConstructor" 130 | showKind (Constructor CoInductive) = "CoinductiveConstructor" 131 | showKind k = show k 132 | 133 | opClass = if op then ["Operator"] else [] 134 | in kindClass ++ opClass 135 | aspectClasses a = [show a] 136 | 137 | otherAspectClasses = map show . Set.toList 138 | 139 | -- Notes are not included. 140 | noteClasses _ = [] 141 | 142 | link defSite = if defSiteModule defSite == m 143 | then Just [href ("#" ++ show (defSitePos defSite))] 144 | else Nothing 145 | 146 | toMarkdown :: String 147 | -> TopLevelModuleName -> [Either String [(Integer, String, Aspects)]] 148 | -> String 149 | toMarkdown classpr m contents = 150 | concat [ case c of 151 | Left s -> s 152 | Right cs -> 153 | let h = pre . tag "code" . mconcat $ 154 | [ (annotate m pos mi (stringToHtml s)) 155 | | (pos, s, mi) <- cs ] 156 | in renderHtmlFragment (h ! [theclass classpr]) 157 | | c <- contents ] 158 | 159 | convert :: String -> TopLevelModuleName -> TCM String 160 | convert classpr m = 161 | do (info, contents) <- getModule m 162 | return . toMarkdown classpr m . groupLiterate . pairPositions info . TL.unpack $ contents 163 | 164 | markdownAgda :: CommandLineOptions -> String -> SourceFile -> IO String 165 | markdownAgda opts classpr file = 166 | do let check = do 167 | TCM.setCommandLineOptions opts 168 | checkFile file >>= convert classpr 169 | r <- TCM.runTCMTop $ check `catchError` \err -> do 170 | s <- prettyError err 171 | liftIO (putStrLn s) 172 | throwError err 173 | case r of 174 | Right s -> return (dropWhile isSpace s) 175 | Left _ -> exitFailure 176 | 177 | isAgda :: Item a -> Bool 178 | isAgda i = ex == ".lagda" 179 | where 180 | ex = snd . splitExtension . toFilePath . itemIdentifier $ i 181 | 182 | saveDir :: IO a -> IO a 183 | saveDir m = do 184 | origDir <- getCurrentDirectory 185 | m <* setCurrentDirectory origDir 186 | 187 | agdaPandocCompiler :: 188 | ReaderOptions -> WriterOptions -> CommandLineOptions -> (Pandoc -> Compiler Pandoc) -> Compiler (Item String) 189 | agdaPandocCompiler ropt wopt aopt transform = do 190 | i <- getResourceBody 191 | -- TODO get rid of the unsafePerformIO, and have a more solid 192 | -- way of getting the absolute path 193 | cached cacheName $ Compiler $ \env -> do 194 | CompilerDone fp _ <- runCompiler getResourceFilePath env 195 | res :: Item String <- saveDir $ do 196 | -- We set to the directory of the file, we assume that 197 | -- the agda files are in one flat directory which might 198 | -- not be not the one where Hakyll is ran in. 199 | abfp <- canonicalizePath fp 200 | setCurrentDirectory (dropFileName abfp) 201 | s <- markdownAgda aopt "Agda" (SourceFile $ mkAbsolute abfp) 202 | let i' = i {itemBody = T.pack s} 203 | case Pandoc.runPure (traverse (readMarkdown ropt) i') of 204 | Left err -> fail $ "pandocAgdaCompilerWith: Pandoc failed with error " ++ show err 205 | Right i'' -> do 206 | CompilerDone i''' _ <- unCompiler (traverse transform i'') env 207 | return (writePandocWith wopt i''') 208 | return (CompilerDone res mempty) 209 | where 210 | cacheName = "LiterateAgda.pandocAgdaCompilerWith" 211 | 212 | pandocAgdaCompilerWith :: 213 | ReaderOptions -> WriterOptions -> CommandLineOptions -> Compiler (Item String) 214 | pandocAgdaCompilerWith ropt wopt aopt = do 215 | pandocAgdaCompilerWithTransformM ropt wopt aopt return 216 | 217 | -- | The transform must essentially be an IO action (no dependencies) 218 | pandocAgdaCompilerWithTransformM :: 219 | ReaderOptions -> WriterOptions -> CommandLineOptions -> (Pandoc -> Compiler Pandoc) -> Compiler (Item String) 220 | pandocAgdaCompilerWithTransformM ropt wopt aopt transform = do 221 | i <- getResourceBody 222 | if isAgda i 223 | then agdaPandocCompiler ropt wopt aopt transform 224 | else pandocCompilerWithTransformM ropt wopt transform 225 | 226 | pandocAgdaCompiler :: Compiler (Item String) 227 | pandocAgdaCompiler = 228 | pandocAgdaCompilerWith defaultHakyllReaderOptions defaultHakyllWriterOptions defaultOptions 229 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2015, Francesco Mazzoli 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of Jasper Van der Jeugt nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /css/agda.css: -------------------------------------------------------------------------------- 1 | /* Adapted from `src/data/Agda.css' from the Agda package, see 2 | for the license and the copyright 3 | information. 4 | */ 5 | 6 | /* Aspects. */ 7 | pre.Agda a.Comment { color: #B22222 } 8 | pre.Agda a.Keyword { color: #CD6600 } 9 | pre.Agda a.String { color: #B22222 } 10 | pre.Agda a.Number { color: #A020F0 } 11 | pre.Agda a.Symbol { color: #404040 } 12 | pre.Agda a.PrimitiveType { color: #0000CD } 13 | pre.Agda a.Operator {} 14 | 15 | /* NameKinds. */ 16 | pre.Agda a.Bound { color: black } 17 | pre.Agda a.InductiveConstructor { color: #008B00 } 18 | pre.Agda a.CoinductiveConstructor { color: #8B7500 } 19 | pre.Agda a.Datatype { color: #0000CD } 20 | pre.Agda a.Field { color: #EE1289 } 21 | pre.Agda a.Function { color: #0000CD } 22 | pre.Agda a.Module { color: #A020F0 } 23 | pre.Agda a.Postulate { color: #0000CD } 24 | pre.Agda a.Primitive { color: #0000CD } 25 | pre.Agda a.Record { color: #0000CD } 26 | 27 | /* OtherAspects. */ 28 | pre.Agda a.DottedPattern {} 29 | pre.Agda a.UnsolvedMeta { color: black; background: yellow } 30 | pre.Agda a.UnsolvedConstraint { color: black; background: yellow } 31 | pre.Agda a.TerminationProblem { color: black; background: #FFA07A } 32 | pre.Agda a.IncompletePattern { color: black; background: #F5DEB3 } 33 | pre.Agda a.Error { color: red; text-decoration: underline } 34 | pre.Agda a.TypeChecks { color: black; background: #ADD8E6 } 35 | 36 | /* Standard attributes. */ 37 | pre.Agda a { text-decoration: none } 38 | pre.Agda a[href]:hover { background-color: #B4EEB4 } 39 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { 2 | pinnedNixpkgsCommit ? "068984c00e0d4e54b6684d98f6ac47c92dcb642e", # nixos-20.09 3 | pinnedNixpkgsUrl ? "https://github.com/NixOS/nixpkgs/archive/${pinnedNixpkgsCommit}.tar.gz", 4 | pkgs ? import (fetchTarball pinnedNixpkgsUrl) {}, 5 | }: 6 | let 7 | hakyll-agda = pkgs.haskellPackages.callCabal2nix 8 | "hakyll-agda" 9 | ./. 10 | {}; 11 | in { 12 | inherit hakyll-agda; 13 | } 14 | -------------------------------------------------------------------------------- /hakyll-agda.cabal: -------------------------------------------------------------------------------- 1 | Cabal-version: >= 1.10 2 | Name: hakyll-agda 3 | Version: 0.1.13 4 | Author: Francesco Mazzoli (f@mazzo.li) 5 | Maintainer: Francesco Mazzoli (f@mazzo.li) 6 | Build-Type: Simple 7 | License: BSD3 8 | License-File: LICENSE 9 | Category: Web 10 | Synopsis: Wrapper to integrate literate Agda files with Hakyll 11 | Tested-With: GHC==8.4.4 12 | Homepage: https://github.com/bitonic/hakyll-agda 13 | Bug-Reports: https://github.com/bitonic/hakyll-agda/issues 14 | Description: Simple module useful to generate blog posts from literate 15 | Agda files. See 16 | for more info. 17 | 18 | source-repository head 19 | type: git 20 | location: git://github.com/bitonic/hakyll-agda.git 21 | 22 | Library 23 | Build-Depends: base >= 3 && < 5 24 | , Agda >= 2.6.1 25 | , containers 26 | , directory 27 | , filepath 28 | , hakyll >= 4.7.2.0 29 | , mtl 30 | , pandoc 31 | , transformers 32 | , xhtml 33 | , text 34 | GHC-Options: -Wall 35 | Exposed-Modules: Hakyll.Web.Agda 36 | Default-Language: Haskell2010 37 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - '.' 3 | extra-deps: 4 | - Agda-2.6.2@sha256:4119e4477b39807934295a46ca2ade58f861963501683e6687869602d4315fd8,36202 5 | - data-hash-0.2.0.1 6 | - equivalence-0.3.5 7 | - geniplate-mirror-0.7.7 8 | - STMonadTrans-0.4.4 9 | resolver: lts-16.31 10 | --------------------------------------------------------------------------------