diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..6a5b521 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +.stack-work +.vscode diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..92d36ad --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Artem Chirkin (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Artem Chirkin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..b65f731 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# haskell-src-exts-sc + +The library generates code from `haskell-src-exts` AST. +The procedure is as follows: + + 1. pretty-print `haskell-src-exts`s AST + 2. parse the generated code to get `SrcSpanInfo` for each node + 3. combine AST annotated with comments and AST annotated with `SrcSpanInfo` + 4. insert (non-empty) comments into each node, updating `SrcSpanInfo` of all nodes + 5. profit! + +As you can see, the algorithm is quite slow, because it prints and parses code +and modifies all location information on each comment insertion. +On the good side, it is quite flexible and compatible with many versions of `haskell-src-exts-sc`. +Performance is also acceptable if you don't need to invoke it every millisecond. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..4db6e1d --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Language.Haskell.Exts.SimpleComments + +main :: IO () +main = testIt diff --git a/haskell-src-exts-sc.cabal b/haskell-src-exts-sc.cabal new file mode 100644 index 0000000..8cd071c --- /dev/null +++ b/haskell-src-exts-sc.cabal @@ -0,0 +1,35 @@ +name: haskell-src-exts-sc +version: 0.1.0.0 +synopsis: Pretty print haskell code with comments +description: Generate code from haskell-src-exts AST +homepage: https://github.com/achirkin/haskell-src-exts-sc#readme +license: BSD3 +license-file: LICENSE +author: Artem Chirkin +maintainer: chirkin@arch.ethz.ch +copyright: Copyright: (c) 2017 Artem Chirkin +category: bsd3, library, language +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Language.Haskell.Exts.SimpleComments + other-modules: Generics.ApplyTwins + build-depends: base >= 4.7 && < 5 + , haskell-src-exts > 1.18.0 + default-language: Haskell2010 + ghc-options: -Wall + +executable test + hs-source-dirs: app + main-is: Main.hs + ghc-options: -Wall + build-depends: base + , haskell-src-exts-sc + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/achirkin/haskell-src-exts-sc diff --git a/src/Generics/ApplyTwins.hs b/src/Generics/ApplyTwins.hs new file mode 100644 index 0000000..c2d3d3a --- /dev/null +++ b/src/Generics/ApplyTwins.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +module Generics.ApplyTwins (ApplyTwins (), apTwins) where + + +import GHC.Generics + +-- | Combine two arbitrary generic functor-like objects +-- that have exactly same constructor structure (w.r.t. the type parameter). +-- +-- Being applied to two Const functors, prefers value of the first one. +apTwins :: ( Generic (m (x->y)), Generic (m x), Generic (m y) + , ApplyTwins (Rep (m (x->y))) (Rep (m x)) (Rep (m y)) + ) + => m (x -> y) -> m x -> Maybe (m y) +apTwins a b = to <$> apt (from a) (from b) + + +class ApplyTwins mxy mx my where + apt :: mxy p -> mx p -> Maybe (my p) + +instance ApplyTwins U1 U1 U1 where + apt U1 U1 = Just U1 + +instance ApplyTwins (K1 i x) (K1 i x) (K1 i x) where + apt (K1 x) (K1 _) = Just (K1 x) + +instance {-# OVERLAPPING #-} + ApplyTwins (K1 i (x->y)) (K1 i x) (K1 i y) where + apt (K1 f) (K1 x) = Just (K1 (f x)) + +instance {-# OVERLAPPABLE #-} + ( Generic fxy, Generic fx, Generic fy + , ApplyTwins (Rep fxy) (Rep fx) (Rep fy) + ) + => ApplyTwins (K1 i fxy) (K1 i fx) (K1 i fy) where + apt (K1 ff) (K1 fx) = K1 . to <$> apt (from ff) (from fx) + +instance ApplyTwins fxy fx fy + => ApplyTwins (M1 i c fxy) (M1 i c fx) (M1 i c fy) where + apt (M1 ff) (M1 fx) = M1 <$> apt ff fx + +instance ApplyTwins fxy fx fy + => ApplyTwins (Rec1 fxy) (Rec1 fx) (Rec1 fy) where + apt (Rec1 ff) (Rec1 fx) = Rec1 <$> apt ff fx + +instance ( ApplyTwins fxy fx fy + , ApplyTwins gxy gx gy + ) + => ApplyTwins (fxy :+: gxy) (fx :+: gx) (fy :+: gy) where + apt (L1 ff) (L1 fx) = L1 <$> apt ff fx + apt (R1 gf) (R1 gx) = R1 <$> apt gf gx + apt _ _ = Nothing + +instance ( ApplyTwins fxy fx fy + , ApplyTwins gxy gx gy + ) + => ApplyTwins (fxy :*: gxy) (fx :*: gx) (fy :*: gy) where + apt (ff :*: gf) (fx :*: gx) = (:*:) <$> apt ff fx <*> apt gf gx + +instance ( Applicative f, Traversable f + , ApplyTwins gxy gx gy + ) + => ApplyTwins (f :.: gxy) (f :.: gx) (f :.: gy) where + apt (Comp1 fgf) (Comp1 fgx) = fmap Comp1. sequence $ apt <$> fgf <*> fgx diff --git a/src/Language/Haskell/Exts/SimpleComments.hs b/src/Language/Haskell/Exts/SimpleComments.hs new file mode 100644 index 0000000..03a7338 --- /dev/null +++ b/src/Language/Haskell/Exts/SimpleComments.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE RecordWildCards #-} +module Language.Haskell.Exts.SimpleComments + ( testIt, toExactHaddocked + ) where + +import Control.Monad (forM, forM_, join) +import Control.Monad.ST.Strict +import Data.Foldable (foldl') +import Data.List (sortOn) +import Data.Maybe +import Data.STRef + +-- import Language.Haskell.Exts.Build +import Language.Haskell.Exts.Comments +import Language.Haskell.Exts.ExactPrint +import Language.Haskell.Exts.Parser +import Language.Haskell.Exts.Pretty +import Language.Haskell.Exts.SrcLoc +import Language.Haskell.Exts.Syntax + +import Generics.ApplyTwins + + +testIt :: IO () +testIt = do + + let m = Module Nothing + (Just $ ModuleHead Nothing + (ModuleName Nothing "GoodModule") Nothing Nothing + ) [] [] + [ TypeSig Nothing [Ident Nothing "func1"] (TyFun Nothing (TyCon Nothing (UnQual Nothing (Ident Nothing "String"))) (TyCon Nothing (UnQual Nothing (Ident Nothing "String")))) + , PatBind Nothing (PVar Nothing (Ident Nothing "func1")) (UnGuardedRhs Nothing (LeftSection Nothing (Lit Nothing (String Nothing "asgsd" "asgsd")) (QVarOp Nothing (UnQual Nothing (Symbol Nothing "++"))))) Nothing + , DataDecl (Just "This is a data declaration") (DataType Nothing) Nothing (DHead Nothing (Ident Nothing "Hello")) [QualConDecl Nothing Nothing Nothing (ConDecl Nothing (Ident Nothing "HelloA") []) + , QualConDecl Nothing Nothing Nothing (ConDecl (Just "HelloB ConDecl") (Ident (Just "HelloB Ident") "HelloB") [])] (Just (Deriving Nothing [IRule Nothing Nothing Nothing (IHCon Nothing (UnQual Nothing (Ident Nothing "Eq"))) + , IRule Nothing Nothing Nothing (IHCon Nothing (UnQual Nothing (Ident Nothing "Show")))])) + , TypeSig (Just "My first comment\naslo multiline!") [Ident Nothing "func2"] (TyFun Nothing (TyCon Nothing (UnQual Nothing (Ident Nothing "Int"))) (TyCon Nothing (UnQual Nothing (Ident Nothing "String")))) + , PatBind Nothing (PVar Nothing (Ident Nothing "func2")) (UnGuardedRhs Nothing (Var Nothing (UnQual Nothing (Ident Nothing "show")))) Nothing + ] + + + print $ apTwins ((,) <$> m) (fst $ toExactHaddocked m) + + putStrLn "-----------------" + putStrLn $ prettyPrint m + putStrLn "-----------------" + putStrLn $ uncurry exactPrint . toExactHaddocked $ m + putStrLn "-----------------" + + + +toExactHaddocked :: Module (Maybe String) + -> (Module SrcSpanInfo, [Comment]) +toExactHaddocked m'' = runST $ do + -- make location info mutable + mSt <- mapM (\(mt, sloc) -> (,) (sloc, mt) <$> newSTRef sloc) m + let (allLocRefs, allComments') = foldl' f ([],[]) mSt + where + f (ls, cs) ((_, Nothing), l) = (l:ls, cs) + f (ls, cs) ((x, Just c), l) = (l:ls, (x,(c,l)):cs) + -- sort comments by their location, so that insertion of earlier comments + -- does not affect the position of later comments. + allComments = map snd $ sortOn fst allComments' + -- update all locations for each comment + ccs <- forM allComments $ \(comment, locref) -> do + loc <- readSTRef locref + let cSpan = srcInfoSpan loc + (updateLoc, cs) = insertPostComments comment cSpan + forM_ allLocRefs $ flip modifySTRef updateLoc + return cs + mFin <- mapM (readSTRef . snd) mSt + return (mFin, join ccs) + where + m' :: Module SrcSpanInfo + m' = case parseModule $ prettyPrint m'' of + err@ParseFailed {} -> error $ show err + ParseOk r -> r + m :: Module (Maybe String, SrcSpanInfo) + m = fromMaybe + ( error "structure of the original and generate-parsed modules differ." ) + ( apTwins ((,) <$> m'') m' ) + + + + +-- | Insert comments above codepoints +insertPreComments :: String + -> SrcSpan -- ^ location of an element + -- for comments to be attached + -> (SrcSpanInfo -> SrcSpanInfo, [Comment]) +insertPreComments txt locs = (f, cmts) + where + cmtLoc = SrcLoc (srcSpanFilename locs) + startL + startC + cmts = mkComments cmtLoc '|' txt + startL = srcSpanStartLine locs + startC = srcSpanStartColumn locs + lineN = length cmts + f SrcSpanInfo {srcInfoSpan = s, srcInfoPoints = ps} + = SrcSpanInfo + { srcInfoSpan = g s, srcInfoPoints = fmap g ps } + g s | srcSpanEndLine s < startL || + srcSpanStartLine s == startL && srcSpanEndColumn s < startC + = s + | srcSpanStartLine s > startL || + srcSpanStartLine s == startL && srcSpanEndColumn s >= startC + = s { srcSpanStartLine = srcSpanStartLine s + lineN + , srcSpanEndLine = srcSpanEndLine s + lineN + } + | otherwise + = s { srcSpanEndLine = srcSpanEndLine s + lineN } + + +-- | Insert comments right and below codepoints +-- (further along the flow of the program) +insertPostComments :: String + -> SrcSpan -- ^ location of an element + -- for comments to be attached + -> (SrcSpanInfo -> SrcSpanInfo, [Comment]) +insertPostComments txt locs = (f, cmts) + where + cmtLoc = SrcLoc (srcSpanFilename locs) + startL + startC + cmts = mkComments cmtLoc '^' txt + startL = srcSpanEndLine locs + startC = srcSpanEndColumn locs + 1 + lineN = length cmts + f SrcSpanInfo {srcInfoSpan = s, srcInfoPoints = ps} + = SrcSpanInfo + { srcInfoSpan = g s, srcInfoPoints = fmap g ps } + g s | srcSpanEndLine s < startL || + srcSpanStartLine s == startL && srcSpanEndColumn s < startC + = s + | srcSpanStartLine s > startL || + srcSpanStartLine s == startL && srcSpanEndColumn s >= startC + = s { srcSpanStartLine = srcSpanStartLine s + lineN + , srcSpanEndLine = srcSpanEndLine s + lineN + } + | otherwise + = s { srcSpanEndLine = srcSpanEndLine s + lineN } + + + +-- | Make a textual comment into a documentation. +mkComments :: SrcLoc -- ^ location of the comment start + -> Char -- ^ special comment character (i.e. "*" or "^" or "|") + -> String -- ^ text to put into a comment (multiline) + -> [Comment] +mkComments SrcLoc {..} c txt = mkComment srcLine lns + where + lns = indent $ lines txt + indent [] = [] + indent (x:xs) = if c == ' ' + then x:xs + else (' ':c:' ':x) : map (" " ++) xs + mkComment _ [] = [] + mkComment i (x:xs) + = Comment False + (SrcSpan srcFilename i srcColumn i $ srcColumn + 2 + length x) x + : mkComment (i+1) xs diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..79d86bd --- /dev/null +++ b/stack.yaml @@ -0,0 +1,4 @@ +resolver: lts-8.21 + +packages: + - .