



-- {-# LANGUAGE UnicodeSyntax #-}

{-

old stuff, needs some overhaul !

create code snippets from hs src files
(ie. from text enclosed in special snippet comments),
that can subsequently be included in docs

old stuff, just recently ported to trifecta
need to go through them step by step in a more careful manner,
and do some clean up


-}


-- cf
-- http://kwangyulseo.com/2014/02/06/multi-line-strings-in-haskell/

-- deb pkg libghc-pretty-show-dev as a dep
-- + raw-strings-qq pkg

-- {-# LANGUAGE QuasiQuotes #-}


-- only needed for raw strings (?)
-- {-# LANGUAGE DeriveDataTypeable #-}
-- import Text.RawString.QQ





-- |
-- Copyright :  (c) Andreas Reuleaux 2015
-- License   :  BSD2
-- Maintainer:  Andreas Reuleaux <rx@a-rx.info>
-- Stability :  experimental
-- Portability: non-portable
--
-- extract code snippets marked w/ special comments from haskell files
-- idea originally from the RWH book repo.



{-


c <- do h <- openFile "PNM.hs" ReadMode; c <- hGetContents h; return (c)

-}

-- c' = let x `isNotPrefixOf` l = not (x `isPrefixOf` l) in head $ dropWhile ("{-- " `isNotPrefixOf`) $ tails c


{-# LANGUAGE DeriveDataTypeable #-}





-- # aptitude install libghc-missingh-dev
-- (includes: replace, startswith etc.)
import Data.String.Utils



-- hPutStrLn stderr
import System.IO


import Text.Trifecta
import Text.Trifecta.Delta
-- import Text.Parser.Token.Style
-- import Text.Parser.Combinators


import Text.Parser.LookAhead



import Control.Applicative
-- import Control.Monad


-- import System.Console.CmdArgs

-- optparse-applicative
import qualified Options.Applicative as A
-- import Options.Applicative.Arrows
-- import Data.Char


import Text.Regex

import Data.Monoid



fromSuccess :: Result b -> b
fromSuccess (Success x) = x
fromSuccess (Failure doc') = error $ show doc'



parse p s =
  let
    -- p' = runInnerParser $ evalStateT (whiteSpace *> p) piInit
    -- p' = runInnerParser $ (whiteSpace *> p)
    p' = (whiteSpace *> p)
  in
    -- fromSuccess $ parseString p' beginning s
    fromSuccess $ parseString p' (Lines 0 0 0 0) s



-- w/ lookahead - cf RWH - for csv files there
-- maybe can shorten this 
-- but old try from Parsec, maybe change this to lookAhead ?
eol :: (
  Parsing m
  , CharParsing m
  ) => m String
eol =   
  -- mac?
  try (string "\n\r")
  -- win    
  <|> try (string "\r\n")
  -- unix
  <|> string "\n"
  -- ? 
  <|> string "\r"


baseChars = ['a'..'z']++['A'..'Z']++['0'..'9']++"$-_.!*'"




-- |
-- >>> parse openSnippet "{-- snippet foo --}\n"
-- "foo"

openSnippet ::
  (
    Monad m
  , CharParsing m
  ) => m String
openSnippet = do {
  ; string "{--" 
  ; spaces
  ; string "snippet"
  ; spaces
  ; word <- some (oneOf baseChars)
  ; spaces
  ; string "--}"
  ; eol
  ; return word
  }





-- |
-- >>> parse (closeSnippet "foo") "{-- /snippet foo --}\n"
-- "\n"


closeSnippet nm = do
  string "{--" 
  spaces
  string "/snippet"
  spaces
  string nm
  spaces
  string "--}"
  eol



-- |
-- >>> let s = unlines ["{-- snippet foo --}", "bar = 2", "{-- /snippet foo --}"]
-- >>> parse snippet s
-- ("foo","bar = 2\n")



snippet :: (
  Monad m
  , Parsing m
  , CharParsing m
  , LookAheadParsing m
  ) => m (String, String)
snippet = do

  -- old comments (in German), apply to parsec rather than Trifecta
  -- just recently changed try -> lookAhead,
  -- to make it work at all, but need to go through these comments
  -- really, to see if they still apply

  -- hier braucht man das try sonst gibt's pb z B mit Kommentaren
  -- vor dem ersten snippet (die enthalten auch "{-")

  nm <- try openSnippet

  -- hier braucht man das try, sonst gibt's pb bei
  -- Text mit '{' ...'}' zwischen open- und closesnippet
  -- stuff <- manyTill anyChar (try (closeSnippet nm))

  stuff <- manyTill anyChar (lookAhead (closeSnippet nm))

  -- stuff <- manyTill anyChar (closeSnippet nm)
  return (nm, stuff)



-- inspired be src von manyTill
-- parse snippet, discard preceding whitespace
-- so vielleicht auch statt meiner Fkt strip zu verwenden

  
snippet' :: (
  Monad m
  , CharParsing m
  , LookAheadParsing m
  ) => m (String, String)
snippet' =
  (do
       ; s <- snippet
       ; return s
  )
   <|>
   (do 
        ; _ <- anyChar
        ; s <- snippet'
        ; return (s)
   )



  
snips :: (
  Monad m
  , CharParsing m
  , LookAheadParsing m
  ) => m [(String, String)]
snips= (do  
            ; ss <- many (try snippet')
            -- there can be stuff after the last snippet
            ; manyTill anyChar eof
            ; return ss
       )



strip''' s = subRegex (mkRegex "^>>> ") s "> "

-- hm, not that easy
-- strip''' s = subRegex (mkRegex "^>>> ") s "λ> "

strip''  s = subRegex (mkRegex "^-- ") s "" 
strip'   s = subRegex (mkRegex "^-- \\|([ws]*)\n") s "" 
stripDocTest = strip''' . strip'' . strip'


-- takeFileName damit z. B auch mit -fn ./bla/Parser.hs fkt
-- inzw aber auch noch besser: replace...
treat' nm code fname opts = 
  let out =
        "_snippet_"

        -- "snippet_"

        ++ (case fname of { 
                -- Just fn' -> fn'++"_"
                ; Just fn' -> 
                    let fn''= replace "._" "" (replace "/" "_" fn') in
                    fn''++"_"
                ; Nothing -> ""
                }
           ) ++ nm ++ ".hs" in
  withFile (out) WriteMode 
  (\h -> do {
       ; hPutStr h (case fname of {

                        ; Nothing -> (if nicer opts then stripDocTest code else code)

                        ; Just fn -> "-- file: "++ fn ++"\n"++ code
                        }
                   )
       ; putStrLn $ "writing snippet " ++ nm ++ " to " ++ out ++ " ..." 
       }
  )

         
treat contents mayfn opts =
  case (parseString (junk *> snips) (Lines 0 0 0 0) contents) of {
    ; Failure err' -> putStrLn $ show err'
    ; Success ss -> mapM_ (\(nm, code)-> treat' nm code mayfn opts )  ss
    }
                  




-- c' = let x `isNotPrefixOf` l = not (x `isPrefixOf` l) in head $ dropWhile ("{-- " `isNotPrefixOf`) $ tails c

junk :: (Alternative m
        , CharParsing m
        , LookAheadParsing m) => m String 
junk = do {
  ; manyTill anyChar (lookAhead (string "{-- snippet"))
  }


-- newstuff (junk *> openSnippet) "../src/docs.hs"
-- newstuff (junk *> snips) "../src/docs.hs"

newstuff parser filename = do
  result <- parseFromFileEx parser filename
  case result of {
    ; Failure err' -> putStrLn $ show err' 

                      -- Success ss -> mapM_ (\(nm, code)-> treat' nm code $ Just filenm) ss
                      -- Success ss -> mapM_ (\(nm, code)-> treat' nm code $ Nothing) ss
                      -- ; Success ss -> putStrLn $ show ss
    ; Success ss -> putStrLn $ show ss
    }



-- treat c (Just fn) =
--   case (parse snips "" c) of
--     Left err -> putStrLn $ show err 
--     Right ss -> mapM_ (\(nm, code)-> treat' nm code $ Just fn) ss




data Opts = Opts {
  hsfile :: FilePath
  , filenm :: Bool
  , nicer :: Bool
  }
          deriving (Show)


cfg :: A.Parser Opts
cfg = Opts <$>
      
      A.strOption ( A.long "hsfile"
                    A.<> A.short 'h'
                    A.<> A.metavar "FILE"
                    A.<> A.help "haskell file" )

        
      <*> (A.flag False True (A.long "filenm" <> A.short 'f')
          )
      
      <*> (A.flag False True (A.long "nicer" <> A.short 'n')
          )
      


      
      -- <*> option
      -- (str >>= C.parsePbk)
      -- (long "pbk" <> short 'p' <> metavar "PLAYBOOK")

run :: Opts -> IO ()
run opts =
  (do
       ; putStrLn $ "doing foo bar"

       ; (hPutStrLn stderr) . show $ opts
  
       -- ; h <- openFile (hsfile opts) ReadMode
       -- ; contents <- hGetContents h
       -- ; putStr contents
       -- ; hClose h

         
       ; withFile (hsfile opts) ReadMode 
         (\h ->
            (do
                 ; contents <- hGetContents h
                               -- putStr contents
                 ; if filenm opts then
                     -- return ()
                     treat contents (Just $ hsfile opts) opts
                   else
                     treat contents Nothing opts

             
            )
            )
         )

   
   

main :: IO ()
main = A.execParser opts >>= run
  where
    opts = A.info cfg mempty
