content: {-# LANGUAGE PatternGuards #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE MonadComprehensions #-}
  
  module Language.Haskell.Exference.EnvironmentParser
    ( parseModules
    , parseModulesSimple
    , environmentFromModuleAndRatings
    , environmentFromPath
    , haskellSrcExtsParseMode
    , compileWithDict
    )
  where
  
  
  
  import Language.Haskell.Exference
  import Language.Haskell.Exference.ExpressionToHaskellSrc
  import Language.Haskell.Exference.BindingsFromHaskellSrc
  import Language.Haskell.Exference.ClassEnvFromHaskellSrc
  import Language.Haskell.Exference.TypeDeclsFromHaskellSrc
  import Language.Haskell.Exference.TypeFromHaskellSrc
  import Language.Haskell.Exference.Core.FunctionBinding
  import Language.Haskell.Exference.FunctionDecl
  
  import Language.Haskell.Exference.Core.Types
  import Language.Haskell.Exference.SimpleDict
  import Language.Haskell.Exference.Core.Expression
  import Language.Haskell.Exference.Core.ExferenceStats
  
  import Control.DeepSeq
  
  import System.Process
  
  import Control.Applicative ( (<$>), (<*>), (<*) )
  import Control.Arrow ( (***) )
  import Control.Monad ( when, forM_, guard, forM, mplus, mzero )
  import Data.List ( sortBy, find, isSuffixOf )
  import Data.Ord ( comparing )
  import Text.Printf
  import Data.Maybe ( listToMaybe, fromMaybe, maybeToList, catMaybes )
  import Data.Either ( lefts, rights )
  import Control.Monad.Writer.Strict
  import System.Directory ( getDirectoryContents )
  import Control.Exception ( try, SomeException )
  import Data.Bifunctor ( first, second )
  
  import Language.Haskell.Exts.Syntax ( Module(..), Decl(..), ModuleName(..) )
  import Language.Haskell.Exts.Parser ( parseModuleWithMode
                                      , parseModule
                                      , ParseResult (..)
                                      , ParseMode (..)
                                      , defaultParseMode )
  import Language.Haskell.Exts.Extension ( Language (..)
                                         , Extension (..)
                                         , KnownExtension (..) )
  
  import Data.List.Split ( chunksOf )
  import Control.Monad.Trans.MultiRWS
  import Data.HList.ContainsType
  
  import Language.Haskell.Exference.Core.TypeUtils
  
  import qualified Data.Map as M
  import qualified Data.IntMap as IntMap
  
  
  builtInDeclsM :: (Monad m) => MultiRWST r w s m [HsFunctionDecl]
  builtInDeclsM = do
    let consType = (Cons, TypeArrow
              (TypeVar 0)
              (TypeArrow (TypeApp (TypeCons ListCon)
                                  (TypeVar 0))
                         (TypeApp (TypeCons ListCon)
                                  (TypeVar 0))))
    tupleConss <- mapM (\(a,b) -> [(a,y) | y <- unsafeReadType0 b])
      [ (,) (TupleCon 0) "Unit"
      , (,) (TupleCon 2) "a -> b -> (a, b)"
      , (,) (TupleCon 3) "a -> b -> c -> (a, b, c)"
      , (,) (TupleCon 4) "a -> b -> c -> d -> (a, b, c, d)"
      , (,) (TupleCon 5) "a -> b -> c -> d -> e -> (a, b, c, d, e)"
      , (,) (TupleCon 6) "a -> b -> c -> d -> e -> f -> (a, b, c, d, e, f)"
      , (,) (TupleCon 7) "a -> b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g)"
      ]
    return $ consType : tupleConss
  
  builtInDeconstructorsM :: (Monad m) => MultiRWST r w s m [DeconstructorBinding]
  builtInDeconstructorsM = mapM helper ds
   where
    helper (t, xs) = [ (x,xs,False)
                     | x <- unsafeReadType0 t
                     ]
    ds = [ (,) "(a, b)" [(TupleCon 2, [TypeVar 0, TypeVar 1])]
         , (,) "(a, b, c)" [(TupleCon 3, [TypeVar 0, TypeVar 1, TypeVar 2])]
         , (,) "(a, b, c, d)" [(TupleCon 4, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3])]
         , (,) "(a, b, c, d, e)" [(TupleCon 5, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3, TypeVar 4])]
         , (,) "(a, b, c, d, e, f)" [(TupleCon 6, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3, TypeVar 4, TypeVar 5])]
         , (,) "(a, b, c, d, e, f, g)" [(TupleCon 7, [TypeVar 0, TypeVar 1, TypeVar 2, TypeVar 3, TypeVar 4, TypeVar 5, TypeVar 6])]
         ]
  
  -- | Takes a list of bindings, and a dictionary of desired
  -- functions and their rating, and compiles a list of
  -- RatedFunctionBindings.
  --
  -- If a function in the dictionary is not in the list of bindings,
  -- Left is returned with the corresponding name.
  --
  -- Otherwise, the result is Right.
  compileWithDict :: [(QualifiedName, Float)]
                  -> [HsFunctionDecl]
                  -> Either String [RatedHsFunctionDecl]
                  -- function_not_found or all bindings
  compileWithDict ratings binds =
    ratings `forM` \(name, rating) ->
      case find ((name==).fst) binds of
        Nothing    -> Left $ show name
        Just (_,t) -> Right (name, rating, t)
  
  -- | input: a list of filenames for haskell modules and the
  -- parsemode to use for it.
  --
  -- output: the environment extracted from these modules, wrapped
  -- in a Writer that contains warnings/errors.
  parseModules :: forall m r w s
                . ( m ~ MultiRWST r w s IO
                  , ContainsType [String] w
                  )
               => [(ParseMode, String)]
               -> m
                    ( [HsFunctionDecl]
                    , [DeconstructorBinding]
                    , StaticClassEnv
                    , [QualifiedName]
                    , TypeDeclMap
                    )
  parseModules l = do
    rawTuples <- lift $ mapM hRead l
    let eParsed = map hParse rawTuples
    {-
    let h :: Decl -> IO ()
        h i@(InstDecl _ _ _ _ _ _ _) = do
          pprint i >>= print
        h _ = return ()
    forM_ (rights eParsed) $ \(Module _ _ _ _ _ _ ds) ->
      forM_ ds h
    -}
    -- forM_ (rights eParsed) $ \m -> pprintTo 10000 m >>= print
    mapM_ (mTell . (:[])) $ lefts eParsed
    let mods = rights eParsed
    let ds = getDataTypes mods
    typeDeclsE <- getTypeDecls ds mods
    lefts typeDeclsE `forM_` (mTell . (:[]))
    let typeDecls = M.fromList $ (\x -> (tdecl_name x, x)) <$> rights typeDeclsE
    (cntxt@(StaticClassEnv clss insts), n_insts) <- getClassEnv ds typeDecls mods
    -- TODO: try to exfere this stuff
    (decls, deconss) <- do
      stuff <- mapM (hExtractBinds cntxt ds typeDecls) mods
      return $ concat *** concat $ unzip stuff
    let clssNames = fmap tclass_name clss
    let allValidNames = ds ++ clssNames
    let
      dataToBeChecked :: [(String, HsType)]
      dataToBeChecked =
           [ ("the instance data for " ++ show i, t)
           | insts' <- M.elems insts
           , i@(HsInstance _ _ ts) <- insts'
           , t <- ts]
        ++ [ ("the binding " ++ show n, t)
           | (n, t) <- decls]
    let
      check :: String -> HsType -> m ()
      check s t = do
        findInvalidNames allValidNames t `forM_` \n ->
          mTell ["unknown binding '"++show n++"' used in " ++ s]
    dataToBeChecked `forM_` uncurry check
    mTell ["got " ++ show (length clss) ++ " classes"]
    mTell ["and " ++ show (n_insts) ++ " instances"]
    mTell ["(-> " ++ show (length $ concat $ M.elems $ insts) ++ " instances after inflation)"]
    mTell ["and " ++ show (length decls) ++ " function decls"]
    builtInDecls          <- builtInDeclsM
    builtInDeconstructors <- builtInDeconstructorsM
    return $ ( builtInDecls++decls
             , builtInDeconstructors++deconss
             , cntxt
             , allValidNames
             , typeDecls
             )
    where
      hRead :: (ParseMode, String) -> IO (ParseMode, String)
      hRead (mode, s) = (,) mode <$> readFile s
      hParse :: (ParseMode, String) -> Either String Module
      hParse (mode, content) = case parseModuleWithMode mode content of
        f@(ParseFailed _ _) -> Left $ show f
        ParseOk modul       -> Right modul
      hExtractBinds :: StaticClassEnv
                    -> [QualifiedName]
                    -> TypeDeclMap
                    -> Module
                    -> m ([HsFunctionDecl], [DeconstructorBinding])
      hExtractBinds cntxt ds tDeclMap modul@(Module _ (ModuleName _mname) _ _ _ _ _) = do
        -- tell $ return $ mname
        eFromData <- getDataConss (sClassEnv_tclasses cntxt) ds tDeclMap [modul]
        eDecls <- (++)
          <$> getDecls ds (sClassEnv_tclasses cntxt) tDeclMap [modul]
          <*> getClassMethods (sClassEnv_tclasses cntxt) ds tDeclMap [modul]
        mapM_ (mTell . (:[])) $ lefts eFromData ++ lefts eDecls
        -- tell $ map show $ rights ebinds
        let (binds1s, deconss) = unzip $ rights eFromData
            binds2 = rights eDecls
        return $ ( concat binds1s ++ binds2, deconss )
  
  -- | A simplified version of environmentFromModules where the input
  -- is just one module, parsed with some default ParseMode;
  -- the output is transformed so that all functionsbindings get
  -- a rating of 0.0.
  parseModulesSimple :: ( ContainsType [String] w
                        )
                     => String
                     -> MultiRWST r w s IO
                          ( [RatedHsFunctionDecl]
                          , [DeconstructorBinding]
                          , StaticClassEnv
                          , [QualifiedName]
                          , TypeDeclMap
                          )
  parseModulesSimple s = helper
                     <$> parseModules [(haskellSrcExtsParseMode s, s)]
   where
    addRating (a,b) = (a,0.0,b)
    helper (decls, deconss, cntxt, ds, tdm) = (addRating <$> decls, deconss, cntxt, ds, tdm)
  
  ratingsFromFile :: String -> IO (Either String [(QualifiedName, Float)])
  ratingsFromFile = (fmap . first) show . (try :: IO a -> IO (Either SomeException a))
    . fmap (map (\[name, float] -> (parseQualifiedName name, read float)) . chunksOf 2 . words)
    . readFile
  
  
  -- TODO: add warnings for ratings not applied
  environmentFromModuleAndRatings :: ( ContainsType [String] w
                                     )
                                  => String
                                  -> String
                                  -> MultiRWST r w s IO
                                      ( [FunctionBinding]
                                      , [DeconstructorBinding]
                                      , StaticClassEnv
                                      , [QualifiedName]
                                      , TypeDeclMap
                                      )
  environmentFromModuleAndRatings s1 s2 = do
    let exts1 = [ TypeOperators
                , ExplicitForAll
                , ExistentialQuantification
                , TypeFamilies
                , FunctionalDependencies
                , FlexibleContexts
                , MultiParamTypeClasses ]
        exts2 = map EnableExtension exts1
        mode = ParseMode (s1++".hs")
                         Haskell2010
                         exts2
                         False
                         False
                         Nothing
                         False
    (decls, deconss, cntxt, ds, tdm) <- parseModules [(mode, s1)]
    r <- lift $ ratingsFromFile s2
    case r of
      Left e -> do
        mTell ["could not parse ratings!",e]
        return ([], [], cntxt, [], tdm)
      Right ratings -> do
        let f (a,b) = declToBinding
                    $ ( a
                      , fromMaybe 0.0 (lookup a ratings)
                      , b
                      )
        return $ (map f decls, deconss, cntxt, ds, tdm)
  
  
  environmentFromPath :: ( ContainsType [String] w
                         )
                      => FilePath
                      -> MultiRWST r w s IO
                           ( [FunctionBinding]
                           , [DeconstructorBinding]
                           , StaticClassEnv
                           , [QualifiedName]
                           , TypeDeclMap
                           )
  environmentFromPath p = do
    files <- lift $ getDirectoryContents p
    let modules = ((p ++ "/")++) <$> filter (".hs" `isSuffixOf`) files
    let ratings = ((p ++ "/")++) <$> filter (".ratings" `isSuffixOf`) files
    (decls, deconss, cntxt, dts, tdm) <- parseModules
      [ (mode, m)
      | m <- modules
      , let mode = haskellSrcExtsParseMode m]
    rResult <- lift $ ratingsFromFile `mapM` ratings
    let rs = [x | Right xs <- rResult, x <- xs]
    sequence_ $ do
      Left err <- rResult
      return $ mTell ["could not parse rating file", err]
    (rs' :: [(QualifiedName, Float)]) <- fmap join $ sequence $ do
      (rName, rVal) <- rs
      return $ do
        dIds <- fmap join $ sequence $ do
          (dName, _) <- decls
          return $ do
            return $ do
              guard (show rName == show dName)
              return (dName, rVal)
        case dIds of
          [] -> do
            mTell ["rating could not be applied: " ++ show rName]
            return []
          [x] ->
            return [x]
          _ -> do
            mTell ["duplicate function: " ++ show rName]
            return []
    let f (a,b) = declToBinding
                $ ( a
                  , fromMaybe 0.0 (lookup a rs')
                  , b
                  )
    return $ (map f decls, deconss, cntxt, dts, tdm)
  