exference-1.6.0.0: src/Language/Haskell/Exference/ClassEnvFromHaskellSrc.hs

{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MonadComprehensions #-}

module Language.Haskell.Exference.ClassEnvFromHaskellSrc
  ( getClassEnv
  )
where



import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.Pretty
import Language.Haskell.Exference.Core.FunctionBinding
import Language.Haskell.Exference.TypeFromHaskellSrc
import Language.Haskell.Exference.TypeDeclsFromHaskellSrc
import Language.Haskell.Exference.Core.Types
import Language.Haskell.Exference.Core.TypeUtils

import qualified Data.Map.Strict as M
import qualified Data.Map.Lazy as LazyMap
import Control.Monad.State.Strict
import Control.Monad.Trans.Either
import Control.Monad.Writer.Strict

import Control.Applicative ( (<$>), (<*>), Applicative )

import Data.Maybe ( fromMaybe, mapMaybe )
import Data.Either ( lefts, rights )
import Data.List ( find )
import Data.Traversable ( traverse, for )

import Control.Monad.Trans.MultiRWS
import Data.HList.ContainsType

import Debug.Trace



-- | returns the environment and the number of class instances
--   found (before inflating the instances). The number of
--   classes can be derived from the other output.
--   The count may be used to inform the user (post-inflation count
--   would be bad for that purpose.)
getClassEnv :: ( ContainsType [String] w
               , MonadFix m
               , Applicative m
               )
            => [QualifiedName]
            -> TypeDeclMap
            -> [Module]
            -> MultiRWST r w s m (StaticClassEnv, Int)
getClassEnv ds tDeclMap ms = do
  etcs <- getTypeClasses ds tDeclMap ms
  mapM_ (mTell . (:[])) $ lefts etcs
  let tcs = rights etcs
  einsts <- getInstances tcs ds tDeclMap ms
  mapM_ (mTell . (:[])) $ lefts einsts
  let insts_uninflated = rights einsts
  let insts = inflateInstances insts_uninflated
  return (mkStaticClassEnv tcs insts, length insts_uninflated)

type TempAsst = (QualifiedName, [HsType])

getTypeClasses :: forall m r w s m0
                . ( MonadFix m0
                  , Applicative m0
                  , m ~ MultiRWST r w s m0
                  )
               => [QualifiedName]
               -> TypeDeclMap
               -> [Module]
               -> m [Either String HsTypeClass]
getTypeClasses ds tDeclMap ms = do
  secondMap :: M.Map QualifiedName (Either String ([TempAsst], [TVarId])) <-
    fmap M.fromList $ sequence
      [ [ (qn, x) --m (inner) -- []
        | let qn = convertModuleName moduleName name
        , x <- withMultiStateA (ConvData 0 M.empty) $ runEitherT $ let
              convF (ClassA qname types) =
                (,) (convertQName    (Just moduleName) ds qname)
                <$> types `forM` convertTypeInternal [] (Just moduleName) ds tDeclMap
              convF (ParenA c) = convF c
              convF c = left $ "unknown HsConstraint: " ++ show c
            in (,) <$> mapM convF context <*> mapM tyVarTransform vars
        ]
      | Module _ moduleName _ _ _ _ decls <- ms
      , ClassDecl _loc context name vars _fdeps _cdecls <- decls
      ]
  let
    helper :: QualifiedName
           -> Either String ([TempAsst], [TVarId])
           -> Either String HsTypeClass
    helper qnid eTcRawData = do
      (tempAssts, tVarIds) <- eTcRawData
      HsTypeClass qnid tVarIds
        <$> tempAssts `forM` \(cQnid, vars) ->
          flip HsConstraint vars <$> M.findWithDefault (Right unknownTypeClass) cQnid resultMap

    resultMap :: LazyMap.Map QualifiedName (Either String HsTypeClass)
      -- CARE: DONT USE STRICT METHODS ON THIS MAP
      --       (COMPILER WONT COMPLAIN)
    resultMap = LazyMap.mapWithKey helper secondMap
  return $ LazyMap.elems $ resultMap

getInstances :: forall m m0 r w s
              . ( m ~ MultiRWST r w s m0
                , Monad m0
                )
             => [HsTypeClass]
             -> [QualifiedName]
             -> TypeDeclMap
             -> [Module]
             -> m [Either String HsInstance]
getInstances tcs ds tDeclMap ms = sequence $ do
  Module _ mn _ _ _ _ decls <- ms
  InstDecl _ _ _vars cntxt qname tps _ <- decls
    -- vars would be the forall binds in
    -- > instance forall a . Show (Foo a) where [..]
    -- which we can ignore, right?
  let name = convertQName (Just mn) ds qname
  return $ do
    let instClass = maybe (Left $ "unknown type class: "++show name) Right
                  $ find ((name==).tclass_name) tcs
    let
      sAction :: forall m1
               . ( MonadMultiState ConvData m1
                 )
              => EitherT String m1 HsInstance
      sAction = do
        -- varIds <- mapM tyVarTransform vars
        constrs <- cntxt `forM` \asst ->
          constrTransform
            (Just mn)
            ds
            tDeclMap
            (\str -> find ((str==).tclass_name) tcs)
            asst
        rtps <- convertTypeInternal tcs (Just mn) ds tDeclMap `mapM` tps
        ic <- hoistEither instClass
        return $ HsInstance constrs ic rtps
        -- either (Left . (("instance for "++name++": ")++)) Right
    withMultiStateA (ConvData 0 M.empty) $ runEitherT sAction

constrTransform
  :: (MonadMultiState ConvData m)
  => Maybe ModuleName
  -> [QualifiedName]
  -> TypeDeclMap
  -> (QualifiedName -> Maybe HsTypeClass)
  -> Asst
  -> EitherT String m HsConstraint
constrTransform mn ds tDeclMap tcLookupF (ClassA qname types) = do
  let ctypes = convertTypeInternal [] mn ds tDeclMap `mapM` types
  let qn = convertQName mn ds qname
  maybe
    (left $ "unknown type class: " ++ show qn)
    (\tc -> HsConstraint tc <$> ctypes)
    (tcLookupF qn)
constrTransform mn ds tDeclMap tcLookupF (ParenA c) = constrTransform mn ds tDeclMap tcLookupF c
constrTransform _ _ _ _ c = left $ "unknown HsConstraint: " ++ show c