module Main where

import qualified CreateBinding
import qualified Type
import Parser.Signature (Identifier(Identifier))
import CreateBinding
         (formatForeignCall, formatCArrayWrapper, parseHeader,
          foreignFromParameters, arrayTypeFromBool)

import qualified Text.ParserCombinators.Parsec as Parsec
import qualified Text.ParserCombinators.Parsec.Error as ParsecError

import qualified Options.Applicative as OP

import qualified System.IO as IO
import qualified System.Path.PartClass as PathClass
import qualified System.Path.IO as PathIO
import qualified System.Path as Path
import System.Path.Directory (createDirectoryIfMissing)
import System.Path (takeFileName, (</>))

import Text.Printf (printf)

import qualified Data.Csv as Csv
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as B
import qualified Data.Vector as Vector
import qualified Data.Foldable as Fold
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Traversable (for, sequenceA, traverse)
import Data.Foldable (forM_)
import Data.Vector (Vector)
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.Csv ((.:))
import Data.Tuple.HT (mapSnd, fst3, snd3, thd3)
import Data.Maybe (isNothing)
import Data.Char (toUpper)
import Data.Monoid ((<>))

import qualified Control.Monad.Exception.Synchronous as ME
import qualified Control.Monad.Trans.Writer as MW
import qualified Control.Applicative.HT as App
import qualified Control.Functor.HT as Func
import Control.Monad (when, join)
import Control.Applicative (liftA2, (<$>), (<*>))



class Type.Unification f => Generalize f where
   formatGenericSig :: f Type.Poly -> String

instance Generalize Type.Foreign where
   formatGenericSig = Type.formatForeign

instance Generalize Type.Wrapper where
   formatGenericSig wrapper@(Type.Wrapper inputs _returnType _outputs) =
      concatMap
         (\(typ,dims,dir) ->
            printf "%s -> " (Type.formatArray (arrayTypeFromBool dir) typ dims))
         inputs ++
      "IO " ++ CreateBinding.formatOutputTuple wrapper

prepareClassCall ::
   (Generalize f) =>
   (String, f Type.Poly) -> (String, String, String, Char -> String)
prepareClassCall (name, func) =
   let typeName = map toUpper name
       sig = formatGenericSig func
       newtypeDef =
         printf "newtype %s a = %s {get%s :: %s}" typeName typeName typeName sig
   in  (typeName, sig, newtypeDef,
        \abbr -> printf "(%s %c.%s)" typeName abbr name)

formatClassCall ::
   (Generalize f) => Char -> Char -> (String, f Type.Poly) -> String
formatClassCall singleAbbr doubleAbbr func@(name, _) =
   let (typeName, sig, newtypeDef, typeBranch) = prepareClassCall func
   in  unlines $
      "" :
      "" :
      newtypeDef :
      "" :
      printf "%s :: Class.Real a => %s" name sig :
      printf "%s = get%s $ Class.switchReal %s %s"
         name typeName (typeBranch singleAbbr) (typeBranch doubleAbbr) :
      []

formatClassCallRC :: (Generalize f) => (String, f Type.Poly) -> String
formatClassCallRC func@(name, _) =
   let (typeName, sig, newtypeDef, typeBranch) = prepareClassCall func
   in  unlines $
      "" :
      "" :
      newtypeDef :
      "" :
      printf "%s :: Class.Floating a => %s" name sig :
      printf "%s = get%s $ Class.switchFloating %s %s %s %s" name typeName
         (typeBranch 'S') (typeBranch 'D') (typeBranch 'C') (typeBranch 'Z') :
      []


insertExportList :: [String] -> String -> String
insertExportList exports modul =
   (\(prefix,suffixes) ->
      map fst prefix ++
      case suffixes of
         [] -> []
         (_,suffix):_ ->
            "(\n" ++ unlines (map (printf "   %s,") exports) ++
            "   ) " ++ suffix) $
   break (List.isPrefixOf "where" . snd) $
   zip modul (ListHT.tails modul)

writeHeader ::
   (PathClass.AbsRel ar) =>
   Path.Dir ar -> B.ByteString -> Maybe [String] -> IO (Path.File ar)
writeHeader dstDir modul mexports = do
   let makePath =
         either (ioError . userError) (return . (dstDir </>)) . Path.parse
   tmplFile <- makePath $ B.unpack modul ++ "_tmpl.hs"
   dstFile <- makePath $ B.unpack modul ++ ".hs"
   tmpl <- PathIO.readFile tmplFile
   PathIO.writeFile dstFile $
      "-- Do not edit! Automatically generated by create-lapack-ffi.\n" ++
      maybe tmpl (flip insertExportList tmpl) mexports
   return dstFile

indent :: String -> String
indent = unlines . map ("    " ++) . lines

formatFileError :: (PathClass.AbsRel ar) => Path.File ar -> String -> String
formatFileError path msg =
   printf "\n%s:1:1:\n%s" (Path.toString path) (indent msg)

formatParseError :: Parsec.ParseError -> String
formatParseError err =
   let source = Parsec.errorPos err
   in  printf "\n%s:%d:%d:\n%s"
         (Parsec.sourceName source)
         (Parsec.sourceLine source)
         (Parsec.sourceColumn source)
         (indent $ dropWhile ('\n'==) $
          ParsecError.showErrorMessages
            "or" "unknown parse error" "expecting" "unexpected" "end of input"
            (ParsecError.errorMessages err))

printError :: String -> IO ()
printError = IO.hPutStr IO.stderr

printFileError :: (PathClass.AbsRel ar) => Path.File ar -> String -> IO ()
printFileError path msg = printError $ formatFileError path msg


nameColumn, miscColumn, floatColumn, doubleColumn,
   complexFloatColumn, complexDoubleColumn,
   realColumn, complexColumn, genericColumn :: ByteString
nameColumn = B.pack "Name"
miscColumn = B.pack "Misc"
floatColumn = B.pack "Float"
doubleColumn = B.pack "Double"
complexFloatColumn = B.pack "ComplexFloat"
complexDoubleColumn = B.pack "ComplexDouble"

realColumn = B.pack "Real"
complexColumn = B.pack "Complex"
genericColumn = B.pack "Generic"


data FunctionSet = FunctionSet String (Map ByteString Path.RelFile)

newtype RelFile = RelFile {getRelFile :: Maybe Path.RelFile}

instance Csv.FromField RelFile where
   parseField str =
      fmap RelFile $
      if B.null str
        then return Nothing
        else either fail (return . Just) . Path.parse . B.unpack $ str

instance Csv.FromNamedRecord FunctionSet where
   parseNamedRecord m = do
      name <- m .: nameColumn
      when (null name) $ fail "empty name"
      set <- Csv.parseNamedRecord $ HashMap.delete nameColumn m
      return $ FunctionSet name $ Map.mapMaybe getRelFile set


type URL = String

processFunction ::
   (PathClass.AbsRel ar) =>
   (Path.File ar, Path.File ar) ->
   URL -> String -> Path.File ar ->
   IO (Maybe (Type.Foreign Type.Mono, Type.Wrapper Type.Mono))
processFunction (ffiFile, carrayFile) url haskellName srcPath = do
   content <- PathIO.readFile srcPath
   let msignature = do
         sig <-
            fmap MW.runWriter $
            ME.mapException formatParseError $ ME.fromEither $
            Parsec.parse parseHeader (Path.toString srcPath) content
         when
            (elem (thd3 $ fst sig)
               [Just Type.ComplexSingle, Just Type.ComplexDouble]) $
            ME.throw $
               formatFileError srcPath "complex function result not supported"
         return sig
   case msignature of
      ME.Exception msg -> printError msg >> return Nothing
      ME.Success ((Identifier name, params, returnType), msgs) -> do
         mapM_ (printFileError srcPath) msgs
         let haddock =
               if null url
                 then "\n"
                 else
                     printf "\n-- | <%s>\n"
                        (printf url (Path.toString $ takeFileName srcPath)
                           :: String)
         let foreignSig = foreignFromParameters params returnType
         carrayWrapper <- do
            let (mono,poly) =
                  formatCArrayWrapper (haskellName, params, returnType)
            PathIO.appendFile carrayFile $ haddock ++ mono
            return poly
         PathIO.appendFile ffiFile $
            haddock ++ formatForeignCall ((haskellName, name), foreignSig)
         return $ Just (foreignSig, carrayWrapper)

unifyFunctions ::
   (Type.Unification f, PathClass.AbsRel ar) =>
   String ->
   Map ByteString (Path.File ar, f Type.Mono) ->
   IO (Maybe (f Type.Poly), Maybe (f Type.Poly), Maybe (f Type.Poly))
unifyFunctions msg monoSigs = do
   let unify uni (xPath,xSig) (yPath,ySig) = do
         let m = Type.unifySignature uni xSig ySig
         when (isNothing m) $ do
            printFileError xPath ""
            printFileError yPath msg
         return m
   real <-
      fmap join $ sequenceA $
      liftA2
         (unify Type.unifyPrecision)
         (Map.lookup floatColumn monoSigs)
         (Map.lookup doubleColumn monoSigs)
   complex <-
      fmap join $ sequenceA $
      liftA2
         (unify Type.unifyPrecision)
         (Map.lookup complexFloatColumn monoSigs)
         (Map.lookup complexDoubleColumn monoSigs)
   let generic =
         join $ liftA2 (Type.unifySignature Type.unifyRealComplex) real complex
   return (real, complex, generic)


writePolymorphic ::
   (PathClass.AbsRel ar) =>
   Path.Dir ar ->
   ByteString ->
   Vector (String, sig) ->
   ((String, sig) -> String) ->
   IO ()
writePolymorphic dir name polySigs format = do
   file <- writeHeader dir name (Just $ Fold.toList $ fmap fst polySigs)
   forM_ (Fold.toList polySigs) $ PathIO.appendFile file . format

writeUnified ::
   (PathClass.AbsRel ar, Generalize f) =>
   Path.Dir ar ->
   Vector
      (String,
       (Maybe (f Type.Poly), Maybe (f Type.Poly), Maybe (f Type.Poly))) ->
   IO ()
writeUnified dstDir unifiedSigs = do
   writePolymorphic dstDir realColumn
      (Vector.mapMaybe (Func.mapSnd fst3) unifiedSigs)
      (formatClassCall 'S' 'D')

   writePolymorphic dstDir complexColumn
      (Vector.mapMaybe (Func.mapSnd snd3) unifiedSigs)
      (formatClassCall 'C' 'Z')

   writePolymorphic dstDir genericColumn
      (Vector.mapMaybe (Func.mapSnd thd3) unifiedSigs)
      formatClassCallRC


pathArgument ::
   (PathClass.FileDir fd) =>
   OP.Mod OP.ArgumentFields (Path.AbsRel fd) -> OP.Parser (Path.AbsRel fd)
pathArgument = OP.argument (OP.eitherReader Path.parse)

optParser ::
   OP.Parser
      (URL, (Path.AbsRelFile, Path.AbsRelDir, Path.AbsRelDir, Path.AbsRelDir))
optParser =
   App.lift2 (,)
      (OP.strOption $
         OP.long "fortran-url" <>
         OP.metavar "URL" <>
         OP.value "" <>
         OP.help "Printf template for URL of online help") $
   App.lift4 (,,,)
      (pathArgument $
         OP.metavar "CSV" <>
         OP.help "Spreadsheet containing grouped Fortran file names")
      (pathArgument $
         OP.metavar "SRCDIR" <>
         OP.help "Input directory containing Fortran files")
      (pathArgument $
         OP.metavar "FFIDIR" <>
         OP.help "Output directory for Haskell FFI modules")
      (pathArgument $
         OP.metavar "CARRAYDIR" <>
         OP.help "Output directory for Haskell CArray wrapper modules")

optionInfo :: OP.Parser a -> OP.ParserInfo a
optionInfo parser =
   OP.info
      (OP.helper <*> parser)
      (OP.fullDesc <>
       OP.progDesc
         "Automated generation of low-level and mid-level bindings for LAPACK")


main :: IO ()
main = do
   (url, (csvFile, srcDir, ffiDir, carrayDir)) <-
      OP.execParser $ optionInfo optParser
   createDirectoryIfMissing True ffiDir
   createDirectoryIfMissing True carrayDir

   (headers, functionSets) <-
      either (ioError . userError) return . Csv.decodeByName
       =<< BL.readFile (Path.toString csvFile)

   dstFiles <-
      fmap (Map.fromList . Fold.toList) $
      for (Vector.drop 1 headers) $ \columnName ->
         fmap ((,) columnName) $
         liftA2 (,)
            (writeHeader ffiDir columnName Nothing)
            (writeHeader carrayDir columnName Nothing)

   sigs <-
      for functionSets $ \(FunctionSet name files) ->
         fmap ((,) name . Map.mapMaybe id) $
         sequenceA $
         flip Map.mapWithKey files $ \modul file -> do
            let srcPath = srcDir </> file
            fmap ((,) srcPath) <$>
               processFunction (dstFiles Map.! modul) url name srcPath

   let runUnification dstDir msg select =
         writeUnified dstDir =<<
         traverse (Func.mapSnd (unifyFunctions msg . fmap (mapSnd select))) sigs

   runUnification ffiDir "Cannot generalize FFI functions." fst
   runUnification carrayDir "Cannot generalize CArray functions." snd