content: {-# LANGUAGE CPP, OverloadedStrings, PackageImports, RecordWildCards, ScopedTypeVariables #-}
  -- | In which a Haskell module is deconstructed into extensions and imports.
  module Data.HaskellModule.Parse (readModule) where
  
  import Prelude hiding (fail)
  
  #if MIN_VERSION_base(4,12,0)
  import Control.Monad.Fail (fail)
  #else
  import Prelude (fail)
  #endif
  import "mtl" Control.Monad.Trans
  import qualified Data.ByteString.Char8 as B
  import Data.List
  import Language.Haskell.Exts
  import Text.Printf
  
  import Control.Monad.Trans.Uncertain
  import Data.HaskellModule.Base
  import Data.HaskellSource
  import Language.Haskell.Exts.Location
  
  
  locatedExtensions :: forall si. SrcInfo si
                    => [ModulePragma si] -> Located [ExtensionName]
  locatedExtensions = fmap go . traverse annotated
    where
      go :: [ModulePragma si] -> [ExtensionName]
      go = concatMap extNames
  
      extNames :: ModulePragma si -> [ExtensionName]
      extNames (LanguagePragma _ exts) = map prettyPrint exts
      extNames  OptionsPragma{}        = []  -- TODO: accept "-XExtName"
      extNames _                       = []
  
  locatedImports :: forall si. SrcInfo si
                 => [ImportDecl si] -> Located [QualifiedModule]
  locatedImports = fmap go . traverse annotated
    where
      go :: [ImportDecl si] -> [QualifiedModule]
      go = map qualify
  
      qualify :: ImportDecl si -> QualifiedModule
      qualify decl = (fullName decl, qualifiedName decl)
  
      fullName :: ImportDecl si -> String
      fullName = prettyPrint . importModule
  
      qualifiedName :: ImportDecl si -> Maybe String
      qualifiedName = fmap prettyPrint . importAs
  
  locatedModule :: forall si. SrcInfo si
                => si -> HaskellSource -> Maybe (ModuleHead si) -> Located (Maybe String)
  locatedModule srcInfo source maybeModuleHead = case moduleLine of
      Nothing -> return Nothing
      Just line -> do
        located ((getPointLoc srcInfo) {srcLine = line})
        return (moduleName <$> maybeModuleHead)
    where
      isModuleDecl :: Either B.ByteString String -> Bool
      isModuleDecl (Left xs) = "module " `B.isPrefixOf` xs
      isModuleDecl (Right xs) = "module " `isPrefixOf` xs
  
      moduleLine :: Maybe Int
      moduleLine = fmap index2line $ findIndex isModuleDecl source
  
      moduleName :: ModuleHead si -> String
      moduleName (ModuleHead _ (ModuleName _ name_) _ _) = name_
  
  
  -- line numbers start at 1, list indices start at 0.
  line2index, index2line :: Int -> Int
  line2index = subtract 1
  index2line = (+ 1)
  
  
  -- | A variant of `splitAt` which makes it easy to make `snd` empty.
  --
  -- >>> maybeSplitAt Nothing "abc"
  -- ("abc","")
  --
  -- >>> maybeSplitAt (Just 0) "abc"
  -- ("","abc")
  maybeSplitAt :: Maybe Int -> [a] -> ([a], [a])
  maybeSplitAt Nothing  ys = (ys, [])
  maybeSplitAt (Just i) ys = splitAt i ys
  
  -- | Given n ordered indices before which to split, split the list into n+1 pieces.
  --   Omitted indices will produce empty pieces.
  --
  -- >>> multiSplit [] "foo"
  -- ["foo"]
  --
  -- >>> multiSplit [Just 0, Just 1, Just 2] "foo"
  -- ["","f","o","o"]
  --
  -- >>> multiSplit [Just 0, Just 1, Nothing] "foo"
  -- ["","f","oo",""]
  --
  -- >>> multiSplit [Just 0, Nothing, Just 2] "foo"
  -- ["","fo","","o"]
  --
  -- >>> multiSplit [Just 0, Nothing, Nothing] "foo"
  -- ["","foo","",""]
  --
  -- >>> multiSplit [Nothing, Just 1, Just 2] "foo"
  -- ["f","","o","o"]
  --
  -- >>> multiSplit [Nothing, Just 1, Nothing] "foo"
  -- ["f","","oo",""]
  --
  -- >>> multiSplit [Nothing, Nothing, Just 2] "foo"
  -- ["fo","","","o"]
  --
  -- >>> multiSplit [Nothing, Nothing, Nothing] "foo"
  -- ["foo","","",""]
  multiSplit :: [Maybe Int] -> [a] -> [[a]]
  multiSplit []           xs = [xs]
  multiSplit (j:js) xs = ys1 : ys2 : yss
    where
      (ys:yss) = multiSplit js xs
      (ys1, ys2) = maybeSplitAt j ys
  
  -- | Given n ordered source locations, split the source into n+1 pieces.
  --   Omitted source locations will produce empty pieces.
  splitSource :: [Maybe SrcLoc] -> HaskellSource -> [HaskellSource]
  splitSource = multiSplit . (fmap . fmap) (line2index . srcLine)
  
  
  -- Due to a limitation of haskell-parse-exts, there is no `parseModule`
  -- variant of `readModule` which would parse from a String instead of a file.
  --
  -- According to the documentation [1], only `parseFile` honors language
  -- pragmas, without which PackageImport-style imports will fail to parse.
  --
  -- [1] http://hackage.haskell.org/package/haskell-src-exts-1.14.0.1/docs/Language-Haskell-Exts-Parser.html#t:ParseMode
  
  readModule :: FilePath -> UncertainT IO HaskellModule
  readModule f = do
      s <- lift $ readSource f
      r <- lift $ parseFile f
      case r of
        ParseOk (Module srcInfo moduleDecl pragmas imports decls)
          -> return $ go s srcInfo pragmas moduleDecl imports decls
        ParseOk (XmlPage   {}) -> fail "The XmlSyntax extension is not supported"
        ParseOk (XmlHybrid {}) -> fail "The XmlSyntax extension is not supported"
        ParseFailed loc err -> multilineFail msg
          where
            -- we start with a newline to match ghc's errors
            msg = printf "\n%s:%d:%d: %s" (srcFilename loc) (srcLine loc) (srcColumn loc) err
    where
      go :: SrcInfo si
         => HaskellSource
         -> si
         -> [ModulePragma si]
         -> Maybe (ModuleHead si)
         -> [ImportDecl si]
         -> [Decl si]
         -> HaskellModule
      go source srcInfo pragmas moduleDecl imports decls = HaskellModule {..}
        where
          (languageExtensions,      _) = runLocated (locatedExtensions pragmas)
          (moduleName,      moduleLoc) = runLocated (locatedModule srcInfo source moduleDecl)
          (importedModules, importLoc) = runLocated (locatedImports imports)
          (_,                 declLoc) = runLocated (traverse annotated decls)
  
          sourceParts = splitSource [moduleLoc, importLoc, declLoc] source
          [pragmaSource, moduleSource, importSource, codeSource] = sourceParts
  