initial commit

.gitignore

@@ -0,0 +1,2 @@
+.stack-work
+.vscode

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.

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.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Language.Haskell.Exts.SimpleComments
+
+main :: IO ()
+main = testIt

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

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

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

stack.yaml

@@ -0,0 +1,4 @@
+resolver: lts-8.21
+
+packages:
+  - .