content: -- TODO repl test file path methods.
  
  {-# LANGUAGE OverloadedStrings #-}
  module Pipe.FileSystem where
  import           Control.Monad
  import           Control.Monad.M
  import qualified Data.List as L
  import           Data.String.Util
  import qualified Data.Text as T
  import           Database.SQLite.Simple
  import           System.FilePath
  import           PackageConf
  import           Pipes
  import           System.Directory ( doesDirectoryExist, getDirectoryContents )
  import qualified System.Directory as D
  import           Text.HTML.TagSoup
  import           Text.HTML.TagSoup.Match
  import           Haddock.Artifact
  import           Haddock.Sqlite
  import qualified Module as Ghc
  
  -- TODO the utility of some of these fields is still unclear to me,
  -- at the moment they are filled simply to satisfy the docset spec.
  plist :: String -> String 
  plist str = unlines $
    [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
    , "<!DOCTYPE plist PUBLIC \"-//Apple//DTD PLIST 1.0//EN\" \"http://www.apple.com/DTDs/PropertyList-1.0.dtd\">"
    , "<plist version=\"1.0\">"
    , "<dict>"
    , "<key>CFBundleIdentifier</key>"
    , "<string>" ++ str ++ "</string>"
    , "<key>CFBundleName</key>"
    , "<string>docset for Haskell package " ++ str ++ "</string>"
    , "<key>DocSetPlatformFamily</key>"
    , "<string>haskell</string>" 
    , "<key>isDashDocset</key>"
    , "<true/>"
    , "<key>dashIndexFilePath</key>"
    , "<string>index.html</string>"
    , "</dict>"
    , "</plist>"
    ]
  
  docsetDir :: Ghc.PackageKey -> FilePath
  docsetDir k = Ghc.packageKeyString k ++ ".docset" 
  
  leafs :: (FilePath -> Bool) -> FilePath -> ProducerM FilePath ()
  leafs incPred p = do
    names <- liftIO $ getDirectoryContents p
    forM_ (filter (`notElem` [".", ".."]) names) $ \name' -> do
      let path = p </> name'
      dir <- liftIO . doesDirectoryExist $ path
      (if dir then 
        leafs incPred 
       else if not . incPred $ path then const (return ()) else yield)
        path
  
  type Tag' = Tag T.Text 
  
  remoteUrl :: T.Text -> Bool 
  remoteUrl url = any (T.isPrefixOf url) ["http://", "https://"]
  
  -- toStripped :: FilePath -> FilePath -> Either String FilePath
  -- toStripped pfx original =
           
  common :: FilePath -> FilePath -> FilePath
  common l r = fst . unzip . takeWhile (uncurry (==)) $ zip (normalise l) (normalise r)
  
  parent :: FilePath -> FilePath
  parent = takeDirectory  
         
  stripPrefix :: FilePath -> FilePath -> Either String FilePath 
  stripPrefix prefix path = 
    if L.isPrefixOf prefix path then
      Right $ L.drop (L.length prefix + 1) path
    else 
      Left $ "prefix: " ++ prefix ++ " doesn't agree with:\n  " ++ path
  
  toRelativePath :: FilePath -> FilePath -> Either String FilePath
  toRelativePath base path = do
    let sharedPfx = common base path
    relative <- relativePath sharedPfx
    (</>) relative <$> stripPrefix sharedPfx path 
    where 
      relativePath :: FilePath -> Either String FilePath
      relativePath pfx = 
        joinPath 
         . flip replicate ".." 
         . length 
         . splitPath <$> stripPrefix pfx base 
  
  relativize :: Ghc.PackageKey -> FilePath -> Either String T.Text 
  relativize package p = 
    let filename'      = takeFileName p
        packageSubpath = Ghc.packageKeyString package
        matches        = 
          filter (packageSubpath ==) . reverse $ splitPath (parent p)
    in 
      T.pack <$> 
        if L.null matches then 
          return p -- preserve the path so that it still can be used 
        else -- assume as a package doc file and make relative
          toRelativePath packageSubpath $ L.head matches </> filename'
  
  convertUrl ::  Ghc.PackageKey -> T.Text -> Either String T.Text 
  convertUrl p urlExp 
    | T.null urlExp = Right T.empty
    | otherwise     =  
      if T.isPrefixOf "file:///" urlExp then 
        relativize p (T.unpack . T.drop 7 $ urlExp)
      else if T.isPrefixOf "/" urlExp then 
        relativize p $ T.unpack urlExp
      else
        Right urlExp
        
  attributes :: FilePath -> Tag T.Text -> Either String [Attribute T.Text] 
  attributes _ (TagOpen _ list) = 
    Right list
  attributes src other            =    
    Left $
      "failed to retrieve expected attributes from tag:\n "
      ++ show other  ++ "\n in: \n" ++ src 
      
  -- | Convert local package-compiled haddock links to local relative. 
  convertLink :: Ghc.PackageKey -> FilePath -> Tag' -> Either String Tag'
  convertLink package src tag =
    -- We're only interested in processing links             
    if not $ tagOpenLit "a" (anyAttrNameLit "href") tag then  
      Right tag
    else do
      preserved <- filter (\(n,_) -> n /= "href") <$> attributes src tag 
      let url = fromAttrib "href" tag
      
      if remoteUrl url 
        then 
          Right tag -- ignore remote links
        else do
          url' <- convertUrl package url 
          Right . TagOpen "a" $ ("href", url') : preserved 
  
  pipe_htmlConvert :: 
    Ghc.PackageKey -> PipeM FilePath (FilePath, Maybe String) ()
  pipe_htmlConvert p = 
    forever $ do
      src <- await
      if Just (takeExtension src) /= Just "html" 
        then  
          yield (src, Nothing)
        else do 
          buf <- liftIO . readFile $ src
          -- Link conversion errors are non-fatal.
          case mapM (convertLink p src) . parseTags $ T.pack buf of
            Left e -> do 
              lift . warning $ 
                preposition "failed to convert links" "for" "file" src [e]
              yield (src, Nothing) 
            Right tags ->
              yield (src, Just . T.unpack . renderTags $ tags) 
  
  -- | This consumes a doc file and copies it to a path in 'dstRoot'. 
  -- By pre-condition: 
  --   path has src_root as an ancestor 
  -- By post-condition: 
  --   written dst is the difference of path and src_root,
  --   with by the concatenation of dst_root as it's parent. 
  cons_writeFile :: FilePath -> FilePath -> ConsumerM (FilePath, Maybe String) () 
  cons_writeFile src_root dst_root = forever $ do 
    (path, buf) <- await
    dst_relative_path <- lift . fromE $ stripPrefix src_root path 
  
    -- liftIO . putStrLn $ "src_root: " ++ show src_root
    -- liftIO . putStrLn $ "relative path: " ++ show dst_relative_path
    -- liftIO . putStrLn $ "path: " ++ show path
  
    liftIO $ do 
      let dst_path = dst_root </> dst_relative_path
      --liftIO . putStrLn $ "dst path: " ++ dst_path
      -- create requisite parent directories for the file at the destination
      D.createDirectoryIfMissing True $ parent dst_path 
      case buf of 
        Nothing   -> D.copyFile path dst_path 
        Just buf' -> writeFile dst_path buf'
    
  cons_writeFiles :: FilePath -> ConsumerM PackageConf ()
  cons_writeFiles docsets_root = forever $ do
    conf <- await
    
    lift . msg $ "processing: " ++ (Ghc.packageKeyString . pkg $ conf)
    let docset_folder = docsetDir (pkg conf) 
        dst_root      = docsets_root </> docset_folder 
        dst_doc_root  = dst_root </> "Contents/Resources/Documents/"
  
    liftIO . D.createDirectoryIfMissing True $ dst_doc_root 
   
    -- Copy all files and convert if necessary 
    lift . indentM 2 $ msg "writing files.."
    
    lift . runEffect $ 
      cons_writeFile (htmlDir conf) dst_doc_root 
      <-< pipe_htmlConvert (pkg conf)
      <-< leafs (\p -> Just (takeExtension p) /= Just "haddock") (htmlDir conf)
    
    -- TODO Since the haddock index is already produced in source docs
    -- with latest packaging systems, this is likely unnecessary 
    -- liftIO $ do 
    --    putStrLn "running haddock indexes"
    --    runHaddockIndex (interfaceFile conf) dst_doc_root
    lift . indentM 2 $ msg "writing plist.."
    liftIO . writeFile (dst_root </> "Contents/Info.plist") . plist . 
      Ghc.packageKeyString . pkg $ conf 
  
    let db_path = dst_root </> "Contents/Resources/docSet.dsidx" 
  
    liftIO $ do
      db_exists <- D.doesFileExist db_path 
      when db_exists $ D.removeFile db_path
  
    -- Initialize the SQlite Db
    c' <- liftIO $ do 
          c <- open db_path 
          createTable c
          return c
  
    lift . indentM 2 $ msg "populating database.."
  
    -- Populate the SQlite Db 
    liftIO $ execute_ c' "BEGIN;"
    artifacts <- lift $ toArtifacts (pkg conf) (interfaceFile conf) 
    lift $ mapM_ (fromArtifact (pkg conf) c') artifacts
    liftIO $ execute_ c' "COMMIT;"
    liftIO . close $ c'
    lift . indentM 2 $ msg "finished populating sqlite database.."
    lift $ msg "\n"
  