{- |
  Module      :  $Header$
  Description :  Dictionary insertion
  Copyright   :  (c) 2016 - 2017 Finn Teegen
  License     :  BSD-3-clause

  Maintainer  :  bjp@informatik.uni-kiel.de
  Stability   :  experimental
  Portability :  portable

  TODO
-}

{-# LANGUAGE CPP #-}
module Transformations.Dictionary
  ( insertDicts
  , dictTypeId, qDictTypeId, dictConstrId, qDictConstrId
  , defaultMethodId, qDefaultMethodId, superDictStubId, qSuperDictStubId
  , instFunId, qInstFunId, implMethodId, qImplMethodId
  ) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative      ((<$>), (<*>))
import           Data.Traversable         (traverse)
#endif
import           Control.Monad.Extra      ( concatMapM, liftM, maybeM, when
                                          , zipWithM )
import qualified Control.Monad.State as S (State, runState, gets, modify)

import           Data.List         (inits, nub, partition, tails, zipWith4)
import qualified Data.Map   as Map ( Map, empty, insert, lookup, mapWithKey
                                   , toList )
import           Data.Maybe        (fromMaybe, isJust)
import qualified Data.Set   as Set ( deleteMin, fromList, null, size, toAscList
                                   , toList, union )

import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.SpanInfo
import Curry.Syntax

import Base.CurryTypes
import Base.Expr
import Base.Kinds
import Base.Messages (internalError)
import Base.TopEnv
import Base.Types
import Base.TypeSubst
import Base.Typing

import Env.Class
import Env.Instance
import Env.Interface
import Env.OpPrec
import Env.TypeConstructor
import Env.Value

data DTState = DTState
  { DTState -> ModuleIdent
moduleIdent :: ModuleIdent
  , DTState -> TCEnv
tyConsEnv   :: TCEnv
  , DTState -> ValueEnv
valueEnv    :: ValueEnv
  , DTState -> ClassEnv
classEnv    :: ClassEnv
  , DTState -> InstEnv
instEnv     :: InstEnv
  , DTState -> OpPrecEnv
opPrecEnv   :: OpPrecEnv
  , DTState -> AugmentEnv
augmentEnv  :: AugmentEnv -- for augmenting nullary class methods
  , DTState -> DictEnv
dictEnv     :: DictEnv    -- for dictionary insertion
  , DTState -> SpecEnv
specEnv     :: SpecEnv    -- for dictionary specialization
  , DTState -> Integer
nextId      :: Integer
  }

type DTM = S.State DTState

insertDicts :: InterfaceEnv -> TCEnv -> ValueEnv -> ClassEnv -> InstEnv
            -> OpPrecEnv -> Module PredType
            -> (Module Type, InterfaceEnv, TCEnv, ValueEnv, OpPrecEnv)
insertDicts :: InterfaceEnv
-> TCEnv
-> ValueEnv
-> ClassEnv
-> InstEnv
-> OpPrecEnv
-> Module PredType
-> (Module Type, InterfaceEnv, TCEnv, ValueEnv, OpPrecEnv)
insertDicts intfEnv :: InterfaceEnv
intfEnv tcEnv :: TCEnv
tcEnv vEnv :: ValueEnv
vEnv clsEnv :: ClassEnv
clsEnv inEnv :: InstEnv
inEnv pEnv :: OpPrecEnv
pEnv mdl :: Module PredType
mdl@(Module _ _ m :: ModuleIdent
m _ _ _) =
  (Module Type
mdl', InterfaceEnv
intfEnv', TCEnv
tcEnv', ValueEnv
vEnv', OpPrecEnv
pEnv')
  where initState :: DTState
initState =
          ModuleIdent
-> TCEnv
-> ValueEnv
-> ClassEnv
-> InstEnv
-> OpPrecEnv
-> AugmentEnv
-> DictEnv
-> SpecEnv
-> Integer
-> DTState
DTState ModuleIdent
m TCEnv
tcEnv ValueEnv
vEnv ClassEnv
clsEnv InstEnv
inEnv OpPrecEnv
pEnv AugmentEnv
emptyAugEnv DictEnv
emptyDictEnv SpecEnv
emptySpEnv 1
        (mdl' :: Module Type
mdl', tcEnv' :: TCEnv
tcEnv', vEnv' :: ValueEnv
vEnv', pEnv' :: OpPrecEnv
pEnv') =
          DTM (Module Type)
-> DTState -> (Module Type, TCEnv, ValueEnv, OpPrecEnv)
forall a. DTM a -> DTState -> (a, TCEnv, ValueEnv, OpPrecEnv)
runDTM (Module PredType -> DTM (Module PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Module PredType
mdl DTM (Module PredType)
-> (Module PredType -> DTM (Module Type)) -> DTM (Module Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module PredType -> DTM (Module Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans DTM (Module Type)
-> (Module Type -> DTM (Module Type)) -> DTM (Module Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module Type -> DTM (Module Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize DTM (Module Type)
-> (Module Type -> DTM (Module Type)) -> DTM (Module Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Module Type -> DTM (Module Type)
forall a. Module a -> DTM (Module a)
cleanup) DTState
initState
        intfEnv' :: InterfaceEnv
intfEnv' = ValueEnv -> ClassEnv -> InterfaceEnv -> InterfaceEnv
dictTransInterfaces ValueEnv
vEnv' ClassEnv
clsEnv InterfaceEnv
intfEnv

runDTM :: DTM a -> DTState -> (a, TCEnv, ValueEnv, OpPrecEnv)
runDTM :: DTM a -> DTState -> (a, TCEnv, ValueEnv, OpPrecEnv)
runDTM dtm :: DTM a
dtm s :: DTState
s =
  let (a :: a
a, s' :: DTState
s') = DTM a -> DTState -> (a, DTState)
forall s a. State s a -> s -> (a, s)
S.runState DTM a
dtm DTState
s in (a
a, DTState -> TCEnv
tyConsEnv DTState
s', DTState -> ValueEnv
valueEnv DTState
s', DTState -> OpPrecEnv
opPrecEnv DTState
s')

getModuleIdent :: DTM ModuleIdent
getModuleIdent :: DTM ModuleIdent
getModuleIdent = (DTState -> ModuleIdent) -> DTM ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DTState -> ModuleIdent
moduleIdent

getTyConsEnv :: DTM TCEnv
getTyConsEnv :: DTM TCEnv
getTyConsEnv = (DTState -> TCEnv) -> DTM TCEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DTState -> TCEnv
tyConsEnv

modifyTyConsEnv :: (TCEnv -> TCEnv) -> DTM ()
modifyTyConsEnv :: (TCEnv -> TCEnv) -> DTM ()
modifyTyConsEnv f :: TCEnv -> TCEnv
f = (DTState -> DTState) -> DTM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((DTState -> DTState) -> DTM ()) -> (DTState -> DTState) -> DTM ()
forall a b. (a -> b) -> a -> b
$ \s :: DTState
s -> DTState
s { tyConsEnv :: TCEnv
tyConsEnv = TCEnv -> TCEnv
f (TCEnv -> TCEnv) -> TCEnv -> TCEnv
forall a b. (a -> b) -> a -> b
$ DTState -> TCEnv
tyConsEnv DTState
s }

getValueEnv :: DTM ValueEnv
getValueEnv :: DTM ValueEnv
getValueEnv = (DTState -> ValueEnv) -> DTM ValueEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DTState -> ValueEnv
valueEnv

modifyValueEnv :: (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv :: (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv f :: ValueEnv -> ValueEnv
f = (DTState -> DTState) -> DTM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((DTState -> DTState) -> DTM ()) -> (DTState -> DTState) -> DTM ()
forall a b. (a -> b) -> a -> b
$ \s :: DTState
s -> DTState
s { valueEnv :: ValueEnv
valueEnv = ValueEnv -> ValueEnv
f (ValueEnv -> ValueEnv) -> ValueEnv -> ValueEnv
forall a b. (a -> b) -> a -> b
$ DTState -> ValueEnv
valueEnv DTState
s }

withLocalValueEnv :: DTM a -> DTM a
withLocalValueEnv :: DTM a -> DTM a
withLocalValueEnv act :: DTM a
act = do
  ValueEnv
oldEnv <- DTM ValueEnv
getValueEnv
  a
res <- DTM a
act
  (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> DTM ())
-> (ValueEnv -> ValueEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ ValueEnv -> ValueEnv -> ValueEnv
forall a b. a -> b -> a
const ValueEnv
oldEnv
  a -> DTM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

getClassEnv :: DTM ClassEnv
getClassEnv :: DTM ClassEnv
getClassEnv = (DTState -> ClassEnv) -> DTM ClassEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DTState -> ClassEnv
classEnv

getInstEnv :: DTM InstEnv
getInstEnv :: DTM InstEnv
getInstEnv = (DTState -> InstEnv) -> DTM InstEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DTState -> InstEnv
instEnv

modifyInstEnv :: (InstEnv -> InstEnv) -> DTM ()
modifyInstEnv :: (InstEnv -> InstEnv) -> DTM ()
modifyInstEnv f :: InstEnv -> InstEnv
f = (DTState -> DTState) -> DTM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((DTState -> DTState) -> DTM ()) -> (DTState -> DTState) -> DTM ()
forall a b. (a -> b) -> a -> b
$ \s :: DTState
s -> DTState
s { instEnv :: InstEnv
instEnv = InstEnv -> InstEnv
f (InstEnv -> InstEnv) -> InstEnv -> InstEnv
forall a b. (a -> b) -> a -> b
$ DTState -> InstEnv
instEnv DTState
s }

getPrecEnv :: DTM OpPrecEnv
getPrecEnv :: DTM OpPrecEnv
getPrecEnv = (DTState -> OpPrecEnv) -> DTM OpPrecEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DTState -> OpPrecEnv
opPrecEnv

modifyPrecEnv :: (OpPrecEnv -> OpPrecEnv) -> DTM ()
modifyPrecEnv :: (OpPrecEnv -> OpPrecEnv) -> DTM ()
modifyPrecEnv f :: OpPrecEnv -> OpPrecEnv
f = (DTState -> DTState) -> DTM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((DTState -> DTState) -> DTM ()) -> (DTState -> DTState) -> DTM ()
forall a b. (a -> b) -> a -> b
$ \s :: DTState
s -> DTState
s { opPrecEnv :: OpPrecEnv
opPrecEnv = OpPrecEnv -> OpPrecEnv
f (OpPrecEnv -> OpPrecEnv) -> OpPrecEnv -> OpPrecEnv
forall a b. (a -> b) -> a -> b
$ DTState -> OpPrecEnv
opPrecEnv DTState
s }

getAugEnv :: DTM AugmentEnv
getAugEnv :: DTM AugmentEnv
getAugEnv = (DTState -> AugmentEnv) -> DTM AugmentEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DTState -> AugmentEnv
augmentEnv

setAugEnv :: AugmentEnv -> DTM ()
setAugEnv :: AugmentEnv -> DTM ()
setAugEnv augEnv :: AugmentEnv
augEnv = (DTState -> DTState) -> DTM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((DTState -> DTState) -> DTM ()) -> (DTState -> DTState) -> DTM ()
forall a b. (a -> b) -> a -> b
$ \s :: DTState
s -> DTState
s { augmentEnv :: AugmentEnv
augmentEnv = AugmentEnv
augEnv }

getDictEnv :: DTM DictEnv
getDictEnv :: DTM DictEnv
getDictEnv = (DTState -> DictEnv) -> DTM DictEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DTState -> DictEnv
dictEnv

modifyDictEnv :: (DictEnv -> DictEnv) -> DTM ()
modifyDictEnv :: (DictEnv -> DictEnv) -> DTM ()
modifyDictEnv f :: DictEnv -> DictEnv
f = (DTState -> DTState) -> DTM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((DTState -> DTState) -> DTM ()) -> (DTState -> DTState) -> DTM ()
forall a b. (a -> b) -> a -> b
$ \s :: DTState
s -> DTState
s { dictEnv :: DictEnv
dictEnv = DictEnv -> DictEnv
f (DictEnv -> DictEnv) -> DictEnv -> DictEnv
forall a b. (a -> b) -> a -> b
$ DTState -> DictEnv
dictEnv DTState
s }

withLocalDictEnv :: DTM a -> DTM a
withLocalDictEnv :: DTM a -> DTM a
withLocalDictEnv act :: DTM a
act = do
  DictEnv
oldEnv <- DTM DictEnv
getDictEnv
  a
res <- DTM a
act
  (DictEnv -> DictEnv) -> DTM ()
modifyDictEnv ((DictEnv -> DictEnv) -> DTM ()) -> (DictEnv -> DictEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ DictEnv -> DictEnv -> DictEnv
forall a b. a -> b -> a
const DictEnv
oldEnv
  a -> DTM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

getSpEnv :: DTM SpecEnv
getSpEnv :: DTM SpecEnv
getSpEnv = (DTState -> SpecEnv) -> DTM SpecEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DTState -> SpecEnv
specEnv

setSpEnv :: SpecEnv -> DTM ()
setSpEnv :: SpecEnv -> DTM ()
setSpEnv spEnv :: SpecEnv
spEnv = (DTState -> DTState) -> DTM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((DTState -> DTState) -> DTM ()) -> (DTState -> DTState) -> DTM ()
forall a b. (a -> b) -> a -> b
$ \s :: DTState
s -> DTState
s { specEnv :: SpecEnv
specEnv = SpecEnv
spEnv }

getNextId :: DTM Integer
getNextId :: DTM Integer
getNextId = do
  Integer
nid <- (DTState -> Integer) -> DTM Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DTState -> Integer
nextId
  (DTState -> DTState) -> DTM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((DTState -> DTState) -> DTM ()) -> (DTState -> DTState) -> DTM ()
forall a b. (a -> b) -> a -> b
$ \s :: DTState
s -> DTState
s { nextId :: Integer
nextId = Integer -> Integer
forall a. Enum a => a -> a
succ Integer
nid }
  Integer -> DTM Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
nid

-- -----------------------------------------------------------------------------
-- Augmenting nullary class methods
-- -----------------------------------------------------------------------------

-- To prevent unwanted sharing of non-determinism for nullary class methods
-- we augment them with an additional unit argument.

type AugmentEnv = [QualIdent]

emptyAugEnv :: AugmentEnv
emptyAugEnv :: AugmentEnv
emptyAugEnv = []

initAugEnv :: ValueEnv -> AugmentEnv
initAugEnv :: ValueEnv -> AugmentEnv
initAugEnv = ((QualIdent, ValueInfo) -> AugmentEnv -> AugmentEnv)
-> AugmentEnv -> [(QualIdent, ValueInfo)] -> AugmentEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ValueInfo -> AugmentEnv -> AugmentEnv
bindValue (ValueInfo -> AugmentEnv -> AugmentEnv)
-> ((QualIdent, ValueInfo) -> ValueInfo)
-> (QualIdent, ValueInfo)
-> AugmentEnv
-> AugmentEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualIdent, ValueInfo) -> ValueInfo
forall a b. (a, b) -> b
snd) AugmentEnv
emptyAugEnv ([(QualIdent, ValueInfo)] -> AugmentEnv)
-> (ValueEnv -> [(QualIdent, ValueInfo)]) -> ValueEnv -> AugmentEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueEnv -> [(QualIdent, ValueInfo)]
forall a. TopEnv a -> [(QualIdent, a)]
allBindings
  where bindValue :: ValueInfo -> AugmentEnv -> AugmentEnv
bindValue (Value f :: QualIdent
f True _ (ForAll _ (PredType _ ty :: Type
ty)))
          | Type -> Int
arrowArity Type
ty Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = (QualIdent
f QualIdent -> AugmentEnv -> AugmentEnv
forall a. a -> [a] -> [a]
:)
        bindValue _ = AugmentEnv -> AugmentEnv
forall a. a -> a
id

isAugmented :: AugmentEnv -> QualIdent -> Bool
isAugmented :: AugmentEnv -> QualIdent -> Bool
isAugmented = (QualIdent -> AugmentEnv -> Bool)
-> AugmentEnv -> QualIdent -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip QualIdent -> AugmentEnv -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem

augmentValues :: ValueEnv -> ValueEnv
augmentValues :: ValueEnv -> ValueEnv
augmentValues = (ValueInfo -> ValueInfo) -> ValueEnv -> ValueEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueInfo -> ValueInfo
augmentValueInfo

augmentValueInfo :: ValueInfo -> ValueInfo
augmentValueInfo :: ValueInfo -> ValueInfo
augmentValueInfo (Value f :: QualIdent
f True a :: Int
a (ForAll n :: Int
n (PredType ps :: PredSet
ps ty :: Type
ty)))
  | Type -> Int
arrowArity Type
ty Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = QualIdent -> Bool -> Int -> TypeScheme -> ValueInfo
Value QualIdent
f Bool
True Int
a (TypeScheme -> ValueInfo) -> TypeScheme -> ValueInfo
forall a b. (a -> b) -> a -> b
$ Int -> PredType -> TypeScheme
ForAll Int
n (PredType -> TypeScheme) -> PredType -> TypeScheme
forall a b. (a -> b) -> a -> b
$ PredSet -> Type -> PredType
PredType PredSet
ps Type
ty'
  where ty' :: Type
ty' = Type -> Type
augmentType Type
ty
augmentValueInfo vi :: ValueInfo
vi = ValueInfo
vi

augmentTypes :: TCEnv -> TCEnv
augmentTypes :: TCEnv -> TCEnv
augmentTypes = (TypeInfo -> TypeInfo) -> TCEnv -> TCEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeInfo -> TypeInfo
augmentTypeInfo

augmentTypeInfo :: TypeInfo -> TypeInfo
augmentTypeInfo :: TypeInfo -> TypeInfo
augmentTypeInfo (TypeClass cls :: QualIdent
cls k :: Kind
k ms :: [ClassMethod]
ms) =
  QualIdent -> Kind -> [ClassMethod] -> TypeInfo
TypeClass QualIdent
cls Kind
k ([ClassMethod] -> TypeInfo) -> [ClassMethod] -> TypeInfo
forall a b. (a -> b) -> a -> b
$ (ClassMethod -> ClassMethod) -> [ClassMethod] -> [ClassMethod]
forall a b. (a -> b) -> [a] -> [b]
map ClassMethod -> ClassMethod
augmentClassMethod [ClassMethod]
ms
augmentTypeInfo ti :: TypeInfo
ti = TypeInfo
ti

augmentClassMethod :: ClassMethod -> ClassMethod
augmentClassMethod :: ClassMethod -> ClassMethod
augmentClassMethod mthd :: ClassMethod
mthd@(ClassMethod f :: Ident
f a :: Maybe Int
a (PredType ps :: PredSet
ps ty :: Type
ty))
  | Type -> Int
arrowArity Type
ty Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 =
    Ident -> Maybe Int -> PredType -> ClassMethod
ClassMethod Ident
f (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 0 Maybe Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (PredType -> ClassMethod) -> PredType -> ClassMethod
forall a b. (a -> b) -> a -> b
$ PredSet -> Type -> PredType
PredType PredSet
ps (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
augmentType Type
ty
  | Bool
otherwise = ClassMethod
mthd

augmentInstances :: AugmentEnv -> InstEnv -> InstEnv
augmentInstances :: AugmentEnv -> InstEnv -> InstEnv
augmentInstances = (InstIdent -> InstInfo -> InstInfo) -> InstEnv -> InstEnv
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey ((InstIdent -> InstInfo -> InstInfo) -> InstEnv -> InstEnv)
-> (AugmentEnv -> InstIdent -> InstInfo -> InstInfo)
-> AugmentEnv
-> InstEnv
-> InstEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AugmentEnv -> InstIdent -> InstInfo -> InstInfo
augmentInstInfo

augmentInstInfo :: AugmentEnv -> InstIdent -> InstInfo -> InstInfo
augmentInstInfo :: AugmentEnv -> InstIdent -> InstInfo -> InstInfo
augmentInstInfo augEnv :: AugmentEnv
augEnv (cls :: QualIdent
cls, _) (m :: ModuleIdent
m, ps :: PredSet
ps, is :: [(Ident, Int)]
is) =
  (ModuleIdent
m, PredSet
ps, ((Ident, Int) -> (Ident, Int)) -> [(Ident, Int)] -> [(Ident, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (AugmentEnv -> QualIdent -> (Ident, Int) -> (Ident, Int)
augmentInstImpl AugmentEnv
augEnv QualIdent
cls) [(Ident, Int)]
is)

augmentInstImpl :: AugmentEnv -> QualIdent -> (Ident, Int) -> (Ident, Int)
augmentInstImpl :: AugmentEnv -> QualIdent -> (Ident, Int) -> (Ident, Int)
augmentInstImpl augEnv :: AugmentEnv
augEnv cls :: QualIdent
cls (f :: Ident
f, a :: Int
a)
  | AugmentEnv -> QualIdent -> Bool
isAugmented AugmentEnv
augEnv (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
cls Ident
f) = (Ident
f, Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
  | Bool
otherwise = (Ident
f, Int
a)

class Augment a where
  augment :: a PredType -> DTM (a PredType)

instance Augment Module where
  augment :: Module PredType -> DTM (Module PredType)
augment (Module spi :: SpanInfo
spi ps :: [ModulePragma]
ps m :: ModuleIdent
m es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl PredType]
ds) = do
    AugmentEnv
augEnv <- ValueEnv -> AugmentEnv
initAugEnv (ValueEnv -> AugmentEnv) -> DTM ValueEnv -> DTM AugmentEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DTM ValueEnv
getValueEnv
    AugmentEnv -> DTM ()
setAugEnv AugmentEnv
augEnv
    (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> DTM ())
-> (ValueEnv -> ValueEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ ValueEnv -> ValueEnv
augmentValues
    (TCEnv -> TCEnv) -> DTM ()
modifyTyConsEnv ((TCEnv -> TCEnv) -> DTM ()) -> (TCEnv -> TCEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ TCEnv -> TCEnv
augmentTypes
    (InstEnv -> InstEnv) -> DTM ()
modifyInstEnv ((InstEnv -> InstEnv) -> DTM ()) -> (InstEnv -> InstEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ AugmentEnv -> InstEnv -> InstEnv
augmentInstances AugmentEnv
augEnv
    SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl PredType]
-> Module PredType
forall a.
SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
Module SpanInfo
spi [ModulePragma]
ps ModuleIdent
m Maybe ExportSpec
es [ImportDecl]
is ([Decl PredType] -> Module PredType)
-> StateT DTState Identity [Decl PredType] -> DTM (Module PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl PredType -> StateT DTState Identity (Decl PredType))
-> [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe ModuleIdent
-> Decl PredType -> StateT DTState Identity (Decl PredType)
augmentDecl Maybe ModuleIdent
forall a. Maybe a
Nothing) [Decl PredType]
ds

-- The first parameter of the functions 'augmentDecl', 'augmentEquation' and
-- 'augmentLhs' determines whether we have to unrename the function identifiers
-- before checking if the function has to augmented or not. Furthermore, it
-- specifies the module unqualified identifiers have to be qualified with.
-- The unrenaming is necessary for both class and instance declarations as all
-- identifiers within these have been renamed during the syntax check, while the
-- qualifying is needed for function declarations within instance declarations
-- as the implemented class methods can originate from another module. If not
-- qualified properly, the lookup in the augmentation environment would fail.

-- Since type signatures remain only in class declarations due to desugaring,
-- we can always perform the unrenaming and it is safe to assume that all other
-- functions mentioned in a type signature have to be augmented as well if the
-- first one is affected.

augmentDecl :: Maybe ModuleIdent -> Decl PredType -> DTM (Decl PredType)
augmentDecl :: Maybe ModuleIdent
-> Decl PredType -> StateT DTState Identity (Decl PredType)
augmentDecl _  d :: Decl PredType
d@(TypeSig          p :: SpanInfo
p fs :: [Ident]
fs qty :: QualTypeExpr
qty) = do
  ModuleIdent
m <- DTM ModuleIdent
getModuleIdent
  AugmentEnv
augEnv <- DTM AugmentEnv
getAugEnv
  Decl PredType -> StateT DTState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DTState Identity (Decl PredType))
-> Decl PredType -> StateT DTState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ if AugmentEnv -> QualIdent -> Bool
isAugmented AugmentEnv
augEnv (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ Ident -> Ident
unRenameIdent (Ident -> Ident) -> Ident -> Ident
forall a b. (a -> b) -> a -> b
$ [Ident] -> Ident
forall a. [a] -> a
head [Ident]
fs)
              then SpanInfo -> [Ident] -> QualTypeExpr -> Decl PredType
forall a. SpanInfo -> [Ident] -> QualTypeExpr -> Decl a
TypeSig SpanInfo
p [Ident]
fs (QualTypeExpr -> Decl PredType) -> QualTypeExpr -> Decl PredType
forall a b. (a -> b) -> a -> b
$ QualTypeExpr -> QualTypeExpr
augmentQualTypeExpr QualTypeExpr
qty
              else Decl PredType
d
augmentDecl mm :: Maybe ModuleIdent
mm (FunctionDecl    p :: SpanInfo
p pty :: PredType
pty f :: Ident
f eqs :: [Equation PredType]
eqs) = do
    [Equation PredType]
eqs' <- (Equation PredType -> StateT DTState Identity (Equation PredType))
-> [Equation PredType]
-> StateT DTState Identity [Equation PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe ModuleIdent
-> Equation PredType -> StateT DTState Identity (Equation PredType)
augmentEquation Maybe ModuleIdent
mm) [Equation PredType]
eqs
    ModuleIdent
m <- DTM ModuleIdent
-> (ModuleIdent -> DTM ModuleIdent)
-> Maybe ModuleIdent
-> DTM ModuleIdent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DTM ModuleIdent
getModuleIdent ModuleIdent -> DTM ModuleIdent
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleIdent
mm
    AugmentEnv
augEnv <- DTM AugmentEnv
getAugEnv
    if AugmentEnv -> QualIdent -> Bool
isAugmented AugmentEnv
augEnv (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ Bool -> Ident -> Ident
unRenameIdentIf (Maybe ModuleIdent -> Bool
forall a. Maybe a -> Bool
isJust Maybe ModuleIdent
mm) Ident
f)
      then Decl PredType -> StateT DTState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DTState Identity (Decl PredType))
-> Decl PredType -> StateT DTState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p (PredType -> PredType
augmentPredType PredType
pty) Ident
f [Equation PredType]
eqs'
      else Decl PredType -> StateT DTState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DTState Identity (Decl PredType))
-> Decl PredType -> StateT DTState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p PredType
pty Ident
f [Equation PredType]
eqs'
augmentDecl _  (PatternDecl         p :: SpanInfo
p t :: Pattern PredType
t rhs :: Rhs PredType
rhs) = SpanInfo -> Pattern PredType -> Rhs PredType -> Decl PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern PredType
t (Rhs PredType -> Decl PredType)
-> StateT DTState Identity (Rhs PredType)
-> StateT DTState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rhs PredType -> StateT DTState Identity (Rhs PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Rhs PredType
rhs
augmentDecl _  (ClassDecl    p :: SpanInfo
p cx :: Context
cx cls :: Ident
cls tv :: Ident
tv ds :: [Decl PredType]
ds) = do
  ModuleIdent
m <- DTM ModuleIdent
getModuleIdent
  SpanInfo
-> Context -> Ident -> Ident -> [Decl PredType] -> Decl PredType
forall a.
SpanInfo -> Context -> Ident -> Ident -> [Decl a] -> Decl a
ClassDecl SpanInfo
p Context
cx Ident
cls Ident
tv ([Decl PredType] -> Decl PredType)
-> StateT DTState Identity [Decl PredType]
-> StateT DTState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl PredType -> StateT DTState Identity (Decl PredType))
-> [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe ModuleIdent
-> Decl PredType -> StateT DTState Identity (Decl PredType)
augmentDecl (Maybe ModuleIdent
 -> Decl PredType -> StateT DTState Identity (Decl PredType))
-> Maybe ModuleIdent
-> Decl PredType
-> StateT DTState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> Maybe ModuleIdent
forall a. a -> Maybe a
Just ModuleIdent
m) [Decl PredType]
ds
augmentDecl _  (InstanceDecl p :: SpanInfo
p cx :: Context
cx cls :: QualIdent
cls ty :: InstanceType
ty ds :: [Decl PredType]
ds) =
  SpanInfo
-> Context
-> QualIdent
-> InstanceType
-> [Decl PredType]
-> Decl PredType
forall a.
SpanInfo
-> Context -> QualIdent -> InstanceType -> [Decl a] -> Decl a
InstanceDecl SpanInfo
p Context
cx QualIdent
cls InstanceType
ty ([Decl PredType] -> Decl PredType)
-> StateT DTState Identity [Decl PredType]
-> StateT DTState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl PredType -> StateT DTState Identity (Decl PredType))
-> [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe ModuleIdent
-> Decl PredType -> StateT DTState Identity (Decl PredType)
augmentDecl (Maybe ModuleIdent
 -> Decl PredType -> StateT DTState Identity (Decl PredType))
-> Maybe ModuleIdent
-> Decl PredType
-> StateT DTState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ QualIdent -> Maybe ModuleIdent
qidModule QualIdent
cls) [Decl PredType]
ds
augmentDecl _ d :: Decl PredType
d                             = Decl PredType -> StateT DTState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl PredType
d

augmentEquation :: Maybe ModuleIdent -> Equation PredType
                -> DTM (Equation PredType)
augmentEquation :: Maybe ModuleIdent
-> Equation PredType -> StateT DTState Identity (Equation PredType)
augmentEquation mm :: Maybe ModuleIdent
mm (Equation p :: SpanInfo
p lhs :: Lhs PredType
lhs rhs :: Rhs PredType
rhs) =
  SpanInfo -> Lhs PredType -> Rhs PredType -> Equation PredType
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p (Lhs PredType -> Rhs PredType -> Equation PredType)
-> StateT DTState Identity (Lhs PredType)
-> StateT DTState Identity (Rhs PredType -> Equation PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModuleIdent
-> Lhs PredType -> StateT DTState Identity (Lhs PredType)
augmentLhs Maybe ModuleIdent
mm Lhs PredType
lhs StateT DTState Identity (Rhs PredType -> Equation PredType)
-> StateT DTState Identity (Rhs PredType)
-> StateT DTState Identity (Equation PredType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs PredType -> StateT DTState Identity (Rhs PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Rhs PredType
rhs

augmentLhs :: Maybe ModuleIdent -> Lhs PredType -> DTM (Lhs PredType)
augmentLhs :: Maybe ModuleIdent
-> Lhs PredType -> StateT DTState Identity (Lhs PredType)
augmentLhs mm :: Maybe ModuleIdent
mm lhs :: Lhs PredType
lhs@(FunLhs spi :: SpanInfo
spi f :: Ident
f ts :: [Pattern PredType]
ts) = do
    ModuleIdent
m <- DTM ModuleIdent
-> (ModuleIdent -> DTM ModuleIdent)
-> Maybe ModuleIdent
-> DTM ModuleIdent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DTM ModuleIdent
getModuleIdent ModuleIdent -> DTM ModuleIdent
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleIdent
mm
    AugmentEnv
augEnv <- DTM AugmentEnv
getAugEnv
    if AugmentEnv -> QualIdent -> Bool
isAugmented AugmentEnv
augEnv (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ Bool -> Ident -> Ident
unRenameIdentIf (Maybe ModuleIdent -> Bool
forall a. Maybe a -> Bool
isJust Maybe ModuleIdent
mm) Ident
f)
      then Lhs PredType -> StateT DTState Identity (Lhs PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Lhs PredType -> StateT DTState Identity (Lhs PredType))
-> Lhs PredType -> StateT DTState Identity (Lhs PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Ident -> [Pattern PredType] -> Lhs PredType
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
spi Ident
f
                  ([Pattern PredType] -> Lhs PredType)
-> [Pattern PredType] -> Lhs PredType
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
predUnitType QualIdent
qUnitId [] Pattern PredType -> [Pattern PredType] -> [Pattern PredType]
forall a. a -> [a] -> [a]
: [Pattern PredType]
ts
      else Lhs PredType -> StateT DTState Identity (Lhs PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return Lhs PredType
lhs
augmentLhs _ lhs :: Lhs PredType
lhs               =
  String -> StateT DTState Identity (Lhs PredType)
forall a. String -> a
internalError (String -> StateT DTState Identity (Lhs PredType))
-> String -> StateT DTState Identity (Lhs PredType)
forall a b. (a -> b) -> a -> b
$ "Dictionary.augmentLhs" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Lhs PredType -> String
forall a. Show a => a -> String
show Lhs PredType
lhs

instance Augment Rhs where
  augment :: Rhs PredType -> StateT DTState Identity (Rhs PredType)
augment (SimpleRhs p :: SpanInfo
p e :: Expression PredType
e []) = SpanInfo -> Expression PredType -> Rhs PredType
forall a. SpanInfo -> Expression a -> Rhs a
simpleRhs SpanInfo
p (Expression PredType -> Rhs PredType)
-> StateT DTState Identity (Expression PredType)
-> StateT DTState Identity (Rhs PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Expression PredType
e
  augment rhs :: Rhs PredType
rhs                =
    String -> StateT DTState Identity (Rhs PredType)
forall a. String -> a
internalError (String -> StateT DTState Identity (Rhs PredType))
-> String -> StateT DTState Identity (Rhs PredType)
forall a b. (a -> b) -> a -> b
$ "Dictionary.augment: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rhs PredType -> String
forall a. Show a => a -> String
show Rhs PredType
rhs

instance Augment Expression where
  augment :: Expression PredType
-> StateT DTState Identity (Expression PredType)
augment l :: Expression PredType
l@(Literal     _ _ _) = Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression PredType
l
  augment v :: Expression PredType
v@(Variable _ pty :: PredType
pty v' :: QualIdent
v') = do
    AugmentEnv
augEnv <- DTM AugmentEnv
getAugEnv
    Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType
 -> StateT DTState Identity (Expression PredType))
-> Expression PredType
-> StateT DTState Identity (Expression PredType)
forall a b. (a -> b) -> a -> b
$ if AugmentEnv -> QualIdent -> Bool
isAugmented AugmentEnv
augEnv QualIdent
v'
               then Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo (PredType -> PredType
augmentPredType PredType
pty) QualIdent
v')
                      [SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
predUnitType QualIdent
qUnitId]
               else Expression PredType
v
  augment c :: Expression PredType
c@(Constructor _ _ _) = Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression PredType
c
  augment (Typed       spi :: SpanInfo
spi e :: Expression PredType
e qty :: QualTypeExpr
qty) = (Expression PredType -> QualTypeExpr -> Expression PredType)
-> QualTypeExpr -> Expression PredType -> Expression PredType
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SpanInfo
-> Expression PredType -> QualTypeExpr -> Expression PredType
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
spi) QualTypeExpr
qty (Expression PredType -> Expression PredType)
-> StateT DTState Identity (Expression PredType)
-> StateT DTState Identity (Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Expression PredType
e
  augment (Apply       spi :: SpanInfo
spi e1 :: Expression PredType
e1 e2 :: Expression PredType
e2) = SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
spi (Expression PredType -> Expression PredType -> Expression PredType)
-> StateT DTState Identity (Expression PredType)
-> StateT
     DTState Identity (Expression PredType -> Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Expression PredType
e1 StateT
  DTState Identity (Expression PredType -> Expression PredType)
-> StateT DTState Identity (Expression PredType)
-> StateT DTState Identity (Expression PredType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Expression PredType
e2
  augment (Lambda       spi :: SpanInfo
spi ts :: [Pattern PredType]
ts e :: Expression PredType
e) = SpanInfo
-> [Pattern PredType] -> Expression PredType -> Expression PredType
forall a. SpanInfo -> [Pattern a] -> Expression a -> Expression a
Lambda SpanInfo
spi [Pattern PredType]
ts (Expression PredType -> Expression PredType)
-> StateT DTState Identity (Expression PredType)
-> StateT DTState Identity (Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Expression PredType
e
  augment (Let          spi :: SpanInfo
spi ds :: [Decl PredType]
ds e :: Expression PredType
e) =
    SpanInfo
-> [Decl PredType] -> Expression PredType -> Expression PredType
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
spi ([Decl PredType] -> Expression PredType -> Expression PredType)
-> StateT DTState Identity [Decl PredType]
-> StateT
     DTState Identity (Expression PredType -> Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl PredType -> StateT DTState Identity (Decl PredType))
-> [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe ModuleIdent
-> Decl PredType -> StateT DTState Identity (Decl PredType)
augmentDecl Maybe ModuleIdent
forall a. Maybe a
Nothing) [Decl PredType]
ds StateT
  DTState Identity (Expression PredType -> Expression PredType)
-> StateT DTState Identity (Expression PredType)
-> StateT DTState Identity (Expression PredType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Expression PredType
e
  augment (Case      spi :: SpanInfo
spi ct :: CaseType
ct e :: Expression PredType
e as :: [Alt PredType]
as) =
    SpanInfo
-> CaseType
-> Expression PredType
-> [Alt PredType]
-> Expression PredType
forall a.
SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
Case SpanInfo
spi CaseType
ct (Expression PredType -> [Alt PredType] -> Expression PredType)
-> StateT DTState Identity (Expression PredType)
-> StateT DTState Identity ([Alt PredType] -> Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Expression PredType
e StateT DTState Identity ([Alt PredType] -> Expression PredType)
-> StateT DTState Identity [Alt PredType]
-> StateT DTState Identity (Expression PredType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt PredType -> StateT DTState Identity (Alt PredType))
-> [Alt PredType] -> StateT DTState Identity [Alt PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt PredType -> StateT DTState Identity (Alt PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment [Alt PredType]
as
  augment e :: Expression PredType
e                     =
    String -> StateT DTState Identity (Expression PredType)
forall a. String -> a
internalError (String -> StateT DTState Identity (Expression PredType))
-> String -> StateT DTState Identity (Expression PredType)
forall a b. (a -> b) -> a -> b
$ "Dictionary.augment: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression PredType -> String
forall a. Show a => a -> String
show Expression PredType
e

instance Augment Alt where
  augment :: Alt PredType -> StateT DTState Identity (Alt PredType)
augment (Alt p :: SpanInfo
p t :: Pattern PredType
t rhs :: Rhs PredType
rhs) = SpanInfo -> Pattern PredType -> Rhs PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p Pattern PredType
t (Rhs PredType -> Alt PredType)
-> StateT DTState Identity (Rhs PredType)
-> StateT DTState Identity (Alt PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rhs PredType -> StateT DTState Identity (Rhs PredType)
forall (a :: * -> *). Augment a => a PredType -> DTM (a PredType)
augment Rhs PredType
rhs

augmentPredType :: PredType -> PredType
augmentPredType :: PredType -> PredType
augmentPredType (PredType ps :: PredSet
ps ty :: Type
ty) = PredSet -> Type -> PredType
PredType PredSet
ps (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
augmentType Type
ty

augmentType :: Type -> Type
augmentType :: Type -> Type
augmentType = Type -> Type -> Type
TypeArrow Type
unitType

augmentQualTypeExpr :: QualTypeExpr -> QualTypeExpr
augmentQualTypeExpr :: QualTypeExpr -> QualTypeExpr
augmentQualTypeExpr (QualTypeExpr spi :: SpanInfo
spi cx :: Context
cx ty :: InstanceType
ty) =
  SpanInfo -> Context -> InstanceType -> QualTypeExpr
QualTypeExpr SpanInfo
spi Context
cx (InstanceType -> QualTypeExpr) -> InstanceType -> QualTypeExpr
forall a b. (a -> b) -> a -> b
$ InstanceType -> InstanceType
augmentTypeExpr InstanceType
ty

augmentTypeExpr :: TypeExpr -> TypeExpr
augmentTypeExpr :: InstanceType -> InstanceType
augmentTypeExpr = SpanInfo -> InstanceType -> InstanceType -> InstanceType
ArrowType SpanInfo
NoSpanInfo (InstanceType -> InstanceType -> InstanceType)
-> InstanceType -> InstanceType -> InstanceType
forall a b. (a -> b) -> a -> b
$ SpanInfo -> QualIdent -> InstanceType
ConstructorType SpanInfo
NoSpanInfo QualIdent
qUnitId

-- -----------------------------------------------------------------------------
-- Lifting class and instance declarations
-- -----------------------------------------------------------------------------

-- When we lift class and instance declarations, we can remove the optional
-- default declaration since it has already been considered during the type
-- check.

liftDecls :: Decl PredType -> DTM [Decl PredType]
liftDecls :: Decl PredType -> StateT DTState Identity [Decl PredType]
liftDecls (DefaultDecl _ _) = [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return []
liftDecls (ClassDecl _ _ cls :: Ident
cls tv :: Ident
tv ds :: [Decl PredType]
ds) = do
  ModuleIdent
m <- DTM ModuleIdent
getModuleIdent
  QualIdent
-> Ident
-> [Decl PredType]
-> StateT DTState Identity [Decl PredType]
liftClassDecls (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
cls) Ident
tv [Decl PredType]
ds
liftDecls (InstanceDecl _ cx :: Context
cx cls :: QualIdent
cls ty :: InstanceType
ty ds :: [Decl PredType]
ds) = do
  ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
  let PredType ps :: PredSet
ps ty' :: Type
ty' = [Ident] -> QualTypeExpr -> PredType
toPredType [] (QualTypeExpr -> PredType) -> QualTypeExpr -> PredType
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Context -> InstanceType -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo Context
cx InstanceType
ty
      ps' :: PredSet
ps' = ClassEnv -> PredSet -> PredSet
minPredSet ClassEnv
clsEnv PredSet
ps
  PredSet
-> QualIdent
-> Type
-> [Decl PredType]
-> StateT DTState Identity [Decl PredType]
liftInstanceDecls PredSet
ps' QualIdent
cls Type
ty' [Decl PredType]
ds
liftDecls d :: Decl PredType
d = [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PredType
d]

liftClassDecls :: QualIdent -> Ident -> [Decl PredType] -> DTM [Decl PredType]
liftClassDecls :: QualIdent
-> Ident
-> [Decl PredType]
-> StateT DTState Identity [Decl PredType]
liftClassDecls cls :: QualIdent
cls tv :: Ident
tv ds :: [Decl PredType]
ds = do
  Decl PredType
dictDecl <- QualIdent
-> Ident
-> [Decl PredType]
-> StateT DTState Identity (Decl PredType)
forall a. QualIdent -> Ident -> [Decl a] -> DTM (Decl a)
createClassDictDecl QualIdent
cls Ident
tv [Decl PredType]
ods
  ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
  let fs :: [Ident]
fs = QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
cls ClassEnv
clsEnv
  [Decl PredType]
methodDecls <- (Ident -> StateT DTState Identity (Decl PredType))
-> [Ident] -> StateT DTState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (QualIdent
-> MethodMap -> Ident -> StateT DTState Identity (Decl PredType)
createClassMethodDecl QualIdent
cls MethodMap
ms) [Ident]
fs
  [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType] -> StateT DTState Identity [Decl PredType])
-> [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall a b. (a -> b) -> a -> b
$ Decl PredType
dictDecl Decl PredType -> [Decl PredType] -> [Decl PredType]
forall a. a -> [a] -> [a]
: [Decl PredType]
methodDecls
  where (vds :: [Decl PredType]
vds, ods :: [Decl PredType]
ods) = (Decl PredType -> Bool)
-> [Decl PredType] -> ([Decl PredType], [Decl PredType])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Decl PredType -> Bool
forall a. Decl a -> Bool
isValueDecl [Decl PredType]
ds
        ms :: MethodMap
ms = [Decl PredType] -> MethodMap
methodMap [Decl PredType]
vds

liftInstanceDecls :: PredSet -> QualIdent -> Type -> [Decl PredType]
                  -> DTM [Decl PredType]
liftInstanceDecls :: PredSet
-> QualIdent
-> Type
-> [Decl PredType]
-> StateT DTState Identity [Decl PredType]
liftInstanceDecls ps :: PredSet
ps cls :: QualIdent
cls ty :: Type
ty ds :: [Decl PredType]
ds = do
  Decl PredType
dictDecl <- PredSet
-> QualIdent -> Type -> StateT DTState Identity (Decl PredType)
createInstDictDecl PredSet
ps QualIdent
cls Type
ty
  ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
  let fs :: [Ident]
fs = QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
cls ClassEnv
clsEnv
  [Decl PredType]
methodDecls <- (Ident -> StateT DTState Identity (Decl PredType))
-> [Ident] -> StateT DTState Identity [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PredSet
-> QualIdent
-> Type
-> MethodMap
-> Ident
-> StateT DTState Identity (Decl PredType)
createInstMethodDecl PredSet
ps QualIdent
cls Type
ty MethodMap
ms) [Ident]
fs
  [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType] -> StateT DTState Identity [Decl PredType])
-> [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall a b. (a -> b) -> a -> b
$ Decl PredType
dictDecl Decl PredType -> [Decl PredType] -> [Decl PredType]
forall a. a -> [a] -> [a]
: [Decl PredType]
methodDecls
  where ms :: MethodMap
ms = [Decl PredType] -> MethodMap
methodMap [Decl PredType]
ds

-- Since not every class method needs to be implemented in a class or instance
-- declaration, we use a map to associate a class method identifier with its
-- implementation.

type MethodMap = [(Ident, Decl PredType)]

-- We have to unrename the method's identifiers here because the syntax check
-- has renamed them before.

methodMap :: [Decl PredType] -> MethodMap
methodMap :: [Decl PredType] -> MethodMap
methodMap ds :: [Decl PredType]
ds = [(Ident -> Ident
unRenameIdent Ident
f, Decl PredType
d) | d :: Decl PredType
d@(FunctionDecl _ _ f :: Ident
f _) <- [Decl PredType]
ds]

createClassDictDecl :: QualIdent -> Ident -> [Decl a] -> DTM (Decl a)
createClassDictDecl :: QualIdent -> Ident -> [Decl a] -> DTM (Decl a)
createClassDictDecl cls :: QualIdent
cls tv :: Ident
tv ds :: [Decl a]
ds = do
  ConstrDecl
c <- QualIdent -> Ident -> [Decl a] -> DTM ConstrDecl
forall a. QualIdent -> Ident -> [Decl a] -> DTM ConstrDecl
createClassDictConstrDecl QualIdent
cls Ident
tv [Decl a]
ds
  Decl a -> DTM (Decl a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl a -> DTM (Decl a)) -> Decl a -> DTM (Decl a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> AugmentEnv -> Decl a
forall a.
SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> AugmentEnv -> Decl a
DataDecl SpanInfo
NoSpanInfo (QualIdent -> Ident
dictTypeId QualIdent
cls) [Ident
tv] [ConstrDecl
c] []

createClassDictConstrDecl :: QualIdent -> Ident -> [Decl a] -> DTM ConstrDecl
createClassDictConstrDecl :: QualIdent -> Ident -> [Decl a] -> DTM ConstrDecl
createClassDictConstrDecl cls :: QualIdent
cls tv :: Ident
tv ds :: [Decl a]
ds = do
  let tvs :: [Ident]
tvs  = Ident
tv Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
: (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
filter (Ident -> Ident
unRenameIdent Ident
tv Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
/=) [Ident]
identSupply
      mtys :: [InstanceType]
mtys = (PredType -> InstanceType) -> [PredType] -> [InstanceType]
forall a b. (a -> b) -> [a] -> [b]
map ([Ident] -> Type -> InstanceType
fromType [Ident]
tvs (Type -> InstanceType)
-> (PredType -> Type) -> PredType -> InstanceType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
generalizeMethodType (Type -> Type) -> (PredType -> Type) -> PredType -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredType -> Type
transformMethodPredType)
                 [QualIdent -> Ident -> QualTypeExpr -> PredType
toMethodType QualIdent
cls Ident
tv QualTypeExpr
qty | TypeSig _ fs :: [Ident]
fs qty :: QualTypeExpr
qty <- [Decl a]
ds, Ident
_ <- [Ident]
fs]
  ConstrDecl -> DTM ConstrDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstrDecl -> DTM ConstrDecl) -> ConstrDecl -> DTM ConstrDecl
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Ident -> [InstanceType] -> ConstrDecl
ConstrDecl SpanInfo
NoSpanInfo (QualIdent -> Ident
dictConstrId QualIdent
cls) [InstanceType]
mtys

classDictConstrPredType :: ValueEnv -> ClassEnv -> QualIdent -> PredType
classDictConstrPredType :: ValueEnv -> ClassEnv -> QualIdent -> PredType
classDictConstrPredType vEnv :: ValueEnv
vEnv clsEnv :: ClassEnv
clsEnv cls :: QualIdent
cls = PredSet -> Type -> PredType
PredType PredSet
ps (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow Type
ty [Type]
mtys
  where sclss :: AugmentEnv
sclss = QualIdent -> ClassEnv -> AugmentEnv
superClasses QualIdent
cls ClassEnv
clsEnv
        ps :: PredSet
ps    = [Pred] -> PredSet
forall a. Ord a => [a] -> Set a
Set.fromList [QualIdent -> Type -> Pred
Pred QualIdent
scls (Int -> Type
TypeVariable 0) | QualIdent
scls <- AugmentEnv
sclss]
        fs :: [Ident]
fs    = QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
cls ClassEnv
clsEnv
        mptys :: [PredType]
mptys = (Ident -> PredType) -> [Ident] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map (ValueEnv -> QualIdent -> Ident -> PredType
classMethodType ValueEnv
vEnv QualIdent
cls) [Ident]
fs
        ty :: Type
ty    = Pred -> Type
dictType (Pred -> Type) -> Pred -> Type
forall a b. (a -> b) -> a -> b
$ QualIdent -> Type -> Pred
Pred QualIdent
cls (Type -> Pred) -> Type -> Pred
forall a b. (a -> b) -> a -> b
$ Int -> Type
TypeVariable 0
        mtys :: [Type]
mtys  = (PredType -> Type) -> [PredType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type
generalizeMethodType (Type -> Type) -> (PredType -> Type) -> PredType -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredType -> Type
transformMethodPredType) [PredType]
mptys

createInstDictDecl :: PredSet -> QualIdent -> Type -> DTM (Decl PredType)
createInstDictDecl :: PredSet
-> QualIdent -> Type -> StateT DTState Identity (Decl PredType)
createInstDictDecl ps :: PredSet
ps cls :: QualIdent
cls ty :: Type
ty = do
  PredType
pty <- PredSet -> Type -> PredType
PredType PredSet
ps (Type -> PredType) -> (Type -> Type) -> Type -> PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
arrowBase (Type -> PredType)
-> StateT DTState Identity Type -> StateT DTState Identity PredType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> Type -> StateT DTState Identity Type
getInstDictConstrType QualIdent
cls Type
ty
  SpanInfo
-> PredType
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Decl PredType
forall a.
SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a
funDecl SpanInfo
NoSpanInfo PredType
pty (QualIdent -> Type -> Ident
instFunId QualIdent
cls Type
ty) [] (Expression PredType -> Decl PredType)
-> StateT DTState Identity (Expression PredType)
-> StateT DTState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> Type -> StateT DTState Identity (Expression PredType)
createInstDictExpr QualIdent
cls Type
ty

createInstDictExpr :: QualIdent -> Type -> DTM (Expression PredType)
createInstDictExpr :: QualIdent -> Type -> StateT DTState Identity (Expression PredType)
createInstDictExpr cls :: QualIdent
cls ty :: Type
ty = do
  Type
ty' <- Type -> Type
instType (Type -> Type)
-> StateT DTState Identity Type -> StateT DTState Identity Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> Type -> StateT DTState Identity Type
getInstDictConstrType QualIdent
cls Type
ty
  ModuleIdent
m <- DTM ModuleIdent
getModuleIdent
  ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
  let fs :: AugmentEnv
fs = (Ident -> QualIdent) -> [Ident] -> AugmentEnv
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> QualIdent -> Type -> Ident -> QualIdent
qImplMethodId ModuleIdent
m QualIdent
cls Type
ty) ([Ident] -> AugmentEnv) -> [Ident] -> AugmentEnv
forall a b. (a -> b) -> a -> b
$ QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
cls ClassEnv
clsEnv
  Expression PredType
-> StateT DTState Identity (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType
 -> StateT DTState Identity (Expression PredType))
-> Expression PredType
-> StateT DTState Identity (Expression PredType)
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo (Type -> PredType
predType Type
ty') (QualIdent -> QualIdent
qDictConstrId QualIdent
cls))
             ((Type -> QualIdent -> Expression PredType)
-> [Type] -> AugmentEnv -> [Expression PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo (PredType -> QualIdent -> Expression PredType)
-> (Type -> PredType) -> Type -> QualIdent -> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> PredType
predType) (Type -> [Type]
arrowArgs Type
ty') AugmentEnv
fs)

getInstDictConstrType :: QualIdent -> Type -> DTM Type
getInstDictConstrType :: QualIdent -> Type -> StateT DTState Identity Type
getInstDictConstrType cls :: QualIdent
cls ty :: Type
ty = do
  ValueEnv
vEnv <- DTM ValueEnv
getValueEnv
  ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
  Type -> StateT DTState Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT DTState Identity Type)
-> Type -> StateT DTState Identity Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
forall a. ExpandAliasType a => Type -> a -> a
instanceType Type
ty (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType (PredType -> Type) -> PredType -> Type
forall a b. (a -> b) -> a -> b
$ ValueEnv -> ClassEnv -> QualIdent -> PredType
classDictConstrPredType ValueEnv
vEnv ClassEnv
clsEnv QualIdent
cls

createClassMethodDecl :: QualIdent -> MethodMap -> Ident -> DTM (Decl PredType)
createClassMethodDecl :: QualIdent
-> MethodMap -> Ident -> StateT DTState Identity (Decl PredType)
createClassMethodDecl cls :: QualIdent
cls =
  (Ident -> Ident)
-> (Ident -> StateT DTState Identity (Decl PredType))
-> MethodMap
-> Ident
-> StateT DTState Identity (Decl PredType)
createMethodDecl (QualIdent -> Ident -> Ident
defaultMethodId QualIdent
cls) (QualIdent -> Ident -> StateT DTState Identity (Decl PredType)
defaultClassMethodDecl QualIdent
cls)

defaultClassMethodDecl :: QualIdent -> Ident -> DTM (Decl PredType)
defaultClassMethodDecl :: QualIdent -> Ident -> StateT DTState Identity (Decl PredType)
defaultClassMethodDecl cls :: QualIdent
cls f :: Ident
f = do
  pty :: PredType
pty@(PredType _ ty :: Type
ty) <- QualIdent -> Ident -> StateT DTState Identity PredType
getClassMethodType QualIdent
cls Ident
f
  AugmentEnv
augEnv <- DTM AugmentEnv
getAugEnv
  let augmented :: Bool
augmented = AugmentEnv -> QualIdent -> Bool
isAugmented AugmentEnv
augEnv (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
cls Ident
f)
      pats :: [Pattern PredType]
pats = if Bool
augmented
               then [SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
predUnitType QualIdent
qUnitId []]
               else []
      ty' :: Type
ty' = if Bool
augmented then Type -> Type
arrowBase Type
ty else Type
ty
  Decl PredType -> StateT DTState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DTState Identity (Decl PredType))
-> Decl PredType -> StateT DTState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Decl PredType
forall a.
SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a
funDecl SpanInfo
NoSpanInfo PredType
pty Ident
f [Pattern PredType]
pats (Expression PredType -> Decl PredType)
-> Expression PredType -> Decl PredType
forall a b. (a -> b) -> a -> b
$ Type -> String -> Expression PredType
preludeError (Type -> Type
instType Type
ty') (String -> Expression PredType) -> String -> Expression PredType
forall a b. (a -> b) -> a -> b
$
    "No instance or default method for class operation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
escName Ident
f

getClassMethodType :: QualIdent -> Ident -> DTM PredType
getClassMethodType :: QualIdent -> Ident -> StateT DTState Identity PredType
getClassMethodType cls :: QualIdent
cls f :: Ident
f = do
  ValueEnv
vEnv <- DTM ValueEnv
getValueEnv
  PredType -> StateT DTState Identity PredType
forall (m :: * -> *) a. Monad m => a -> m a
return (PredType -> StateT DTState Identity PredType)
-> PredType -> StateT DTState Identity PredType
forall a b. (a -> b) -> a -> b
$ ValueEnv -> QualIdent -> Ident -> PredType
classMethodType ValueEnv
vEnv QualIdent
cls Ident
f

classMethodType :: ValueEnv -> QualIdent -> Ident -> PredType
classMethodType :: ValueEnv -> QualIdent -> Ident -> PredType
classMethodType vEnv :: ValueEnv
vEnv cls :: QualIdent
cls f :: Ident
f = PredType
pty
  where ForAll _ pty :: PredType
pty = QualIdent -> ValueEnv -> TypeScheme
funType (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
cls Ident
f) ValueEnv
vEnv

createInstMethodDecl :: PredSet -> QualIdent -> Type -> MethodMap -> Ident
                     -> DTM (Decl PredType)
createInstMethodDecl :: PredSet
-> QualIdent
-> Type
-> MethodMap
-> Ident
-> StateT DTState Identity (Decl PredType)
createInstMethodDecl ps :: PredSet
ps cls :: QualIdent
cls ty :: Type
ty =
  (Ident -> Ident)
-> (Ident -> StateT DTState Identity (Decl PredType))
-> MethodMap
-> Ident
-> StateT DTState Identity (Decl PredType)
createMethodDecl (QualIdent -> Type -> Ident -> Ident
implMethodId QualIdent
cls Type
ty) (PredSet
-> QualIdent
-> Type
-> Ident
-> StateT DTState Identity (Decl PredType)
defaultInstMethodDecl PredSet
ps QualIdent
cls Type
ty)

defaultInstMethodDecl :: PredSet -> QualIdent -> Type -> Ident
                      -> DTM (Decl PredType)
defaultInstMethodDecl :: PredSet
-> QualIdent
-> Type
-> Ident
-> StateT DTState Identity (Decl PredType)
defaultInstMethodDecl ps :: PredSet
ps cls :: QualIdent
cls ty :: Type
ty f :: Ident
f = do
  ValueEnv
vEnv <- DTM ValueEnv
getValueEnv
  let pty :: PredType
pty@(PredType _ ty' :: Type
ty') = ValueEnv -> PredSet -> QualIdent -> Type -> Ident -> PredType
instMethodType ValueEnv
vEnv PredSet
ps QualIdent
cls Type
ty Ident
f
  Decl PredType -> StateT DTState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DTState Identity (Decl PredType))
-> Decl PredType -> StateT DTState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Decl PredType
forall a.
SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a
funDecl SpanInfo
NoSpanInfo PredType
pty Ident
f [] (Expression PredType -> Decl PredType)
-> Expression PredType -> Decl PredType
forall a b. (a -> b) -> a -> b
$
    SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
instType Type
ty') (QualIdent -> Ident -> QualIdent
qDefaultMethodId QualIdent
cls Ident
f)

-- Returns the type for a given instance's method of a given class. To this
-- end, the class method's type is stripped of its first predicate (which is
-- the implicit class constraint) and the class variable is replaced with the
-- instance's type. The remaining predicate set is then united with the
-- instance's predicate set.

instMethodType :: ValueEnv -> PredSet -> QualIdent -> Type -> Ident -> PredType
instMethodType :: ValueEnv -> PredSet -> QualIdent -> Type -> Ident -> PredType
instMethodType vEnv :: ValueEnv
vEnv ps :: PredSet
ps cls :: QualIdent
cls ty :: Type
ty f :: Ident
f = PredSet -> Type -> PredType
PredType (PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps'') Type
ty''
  where PredType ps' :: PredSet
ps'  ty' :: Type
ty'  = ValueEnv -> QualIdent -> Ident -> PredType
classMethodType ValueEnv
vEnv QualIdent
cls Ident
f
        PredType ps'' :: PredSet
ps'' ty'' :: Type
ty'' = Type -> PredType -> PredType
forall a. ExpandAliasType a => Type -> a -> a
instanceType Type
ty (PredType -> PredType) -> PredType -> PredType
forall a b. (a -> b) -> a -> b
$ PredSet -> Type -> PredType
PredType (PredSet -> PredSet
forall a. Set a -> Set a
Set.deleteMin PredSet
ps') Type
ty'

createMethodDecl :: (Ident -> Ident) -> (Ident -> DTM (Decl PredType))
                 -> MethodMap -> Ident -> DTM (Decl PredType)
createMethodDecl :: (Ident -> Ident)
-> (Ident -> StateT DTState Identity (Decl PredType))
-> MethodMap
-> Ident
-> StateT DTState Identity (Decl PredType)
createMethodDecl methodId :: Ident -> Ident
methodId defaultDecl :: Ident -> StateT DTState Identity (Decl PredType)
defaultDecl ms :: MethodMap
ms f :: Ident
f =
  (Decl PredType -> Decl PredType)
-> StateT DTState Identity (Decl PredType)
-> StateT DTState Identity (Decl PredType)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Ident -> Decl PredType -> Decl PredType
forall a. Ident -> Decl a -> Decl a
renameDecl (Ident -> Decl PredType -> Decl PredType)
-> Ident -> Decl PredType -> Decl PredType
forall a b. (a -> b) -> a -> b
$ Ident -> Ident
methodId Ident
f) (StateT DTState Identity (Decl PredType)
 -> StateT DTState Identity (Decl PredType))
-> StateT DTState Identity (Decl PredType)
-> StateT DTState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ StateT DTState Identity (Decl PredType)
-> (Decl PredType -> StateT DTState Identity (Decl PredType))
-> Maybe (Decl PredType)
-> StateT DTState Identity (Decl PredType)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Ident -> StateT DTState Identity (Decl PredType)
defaultDecl Ident
f) Decl PredType -> StateT DTState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> MethodMap -> Maybe (Decl PredType)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
f MethodMap
ms)

-- We have to rename the left hand side of lifted function declarations
-- accordingly which is done by the function 'renameDecl'.

renameDecl :: Ident -> Decl a -> Decl a
renameDecl :: Ident -> Decl a -> Decl a
renameDecl f :: Ident
f (FunctionDecl p :: SpanInfo
p a :: a
a _ eqs :: [Equation a]
eqs) = SpanInfo -> a -> Ident -> [Equation a] -> Decl a
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p a
a Ident
f ([Equation a] -> Decl a) -> [Equation a] -> Decl a
forall a b. (a -> b) -> a -> b
$ (Equation a -> Equation a) -> [Equation a] -> [Equation a]
forall a b. (a -> b) -> [a] -> [b]
map Equation a -> Equation a
forall a. Equation a -> Equation a
renameEq [Equation a]
eqs
  where renameEq :: Equation a -> Equation a
renameEq (Equation p' :: SpanInfo
p' lhs :: Lhs a
lhs rhs :: Rhs a
rhs) = SpanInfo -> Lhs a -> Rhs a -> Equation a
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p' (Lhs a -> Lhs a
forall a. Lhs a -> Lhs a
renameLhs Lhs a
lhs) Rhs a
rhs
        renameLhs :: Lhs a -> Lhs a
renameLhs (FunLhs _ _ ts :: [Pattern a]
ts) = SpanInfo -> Ident -> [Pattern a] -> Lhs a
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
NoSpanInfo Ident
f [Pattern a]
ts
        renameLhs _ = String -> Lhs a
forall a. String -> a
internalError "Dictionary.renameDecl.renameLhs"
renameDecl _ _ = String -> Decl a
forall a. String -> a
internalError "Dictionary.renameDecl"

-- -----------------------------------------------------------------------------
-- Creating stub declarations
-- -----------------------------------------------------------------------------

-- For each class method f defined in the processed module we have to introduce
-- a stub method with the same name that selects the appropriate function from
-- the provided dictionary and applies the remaining arguments to it. We also
-- create a stub method for each super class selecting the corresponding super
-- class dictionary from the provided class dictionary.

createStubs :: Decl PredType -> DTM [Decl Type]
createStubs :: Decl PredType -> DTM [Decl Type]
createStubs (ClassDecl _ _ cls :: Ident
cls _ _) = do
  ModuleIdent
m <- DTM ModuleIdent
getModuleIdent
  ValueEnv
vEnv <- DTM ValueEnv
getValueEnv
  ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
  let ocls :: QualIdent
ocls  = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
cls
      sclss :: AugmentEnv
sclss = QualIdent -> ClassEnv -> AugmentEnv
superClasses QualIdent
ocls ClassEnv
clsEnv
      fs :: [Ident]
fs    = QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
ocls ClassEnv
clsEnv
      dictConstrPty :: PredType
dictConstrPty = ValueEnv -> ClassEnv -> QualIdent -> PredType
classDictConstrPredType ValueEnv
vEnv ClassEnv
clsEnv QualIdent
ocls
      (superDictAndMethodTys :: [Type]
superDictAndMethodTys, dictTy :: Type
dictTy) =
        Type -> ([Type], Type)
arrowUnapply (Type -> ([Type], Type)) -> Type -> ([Type], Type)
forall a b. (a -> b) -> a -> b
$ PredType -> Type
transformPredType PredType
dictConstrPty
      (superDictTys :: [Type]
superDictTys, methodTys :: [Type]
methodTys)       =
        Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt (AugmentEnv -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length AugmentEnv
sclss) [Type]
superDictAndMethodTys
      (superStubTys :: [Type]
superStubTys, methodStubTys :: [Type]
methodStubTys)   =
        Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt (AugmentEnv -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length AugmentEnv
sclss) ([Type] -> ([Type], [Type])) -> [Type] -> ([Type], [Type])
forall a b. (a -> b) -> a -> b
$ (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
TypeArrow Type
dictTy) [Type]
superDictAndMethodTys
  [(Type, Ident)]
superDictVs <- (Type -> StateT DTState Identity (Type, Ident))
-> [Type] -> StateT DTState Identity [(Type, Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> StateT DTState Identity (Type, Ident)
freshVar "_#super" (Type -> StateT DTState Identity (Type, Ident))
-> (Type -> Type) -> Type -> StateT DTState Identity (Type, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
instType) [Type]
superDictTys
  [(Type, Ident)]
methodVs <- (Type -> StateT DTState Identity (Type, Ident))
-> [Type] -> StateT DTState Identity [(Type, Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> StateT DTState Identity (Type, Ident)
freshVar "_#meth" (Type -> StateT DTState Identity (Type, Ident))
-> (Type -> Type) -> Type -> StateT DTState Identity (Type, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
instType) [Type]
methodTys
  [[Type]]
methodDictTyss <- (Ident -> Type -> StateT DTState Identity [Type])
-> [Ident] -> [Type] -> StateT DTState Identity [[Type]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (QualIdent -> Ident -> Type -> StateT DTState Identity [Type]
computeMethodDictTypes QualIdent
ocls) [Ident]
fs [Type]
methodTys
  [[(Type, Ident)]]
methodDictVss <- ([Type] -> StateT DTState Identity [(Type, Ident)])
-> [[Type]] -> StateT DTState Identity [[(Type, Ident)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> StateT DTState Identity (Type, Ident))
-> [Type] -> StateT DTState Identity [(Type, Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> StateT DTState Identity (Type, Ident))
 -> [Type] -> StateT DTState Identity [(Type, Ident)])
-> (Type -> StateT DTState Identity (Type, Ident))
-> [Type]
-> StateT DTState Identity [(Type, Ident)]
forall a b. (a -> b) -> a -> b
$ String -> Type -> StateT DTState Identity (Type, Ident)
freshVar "_#dict" (Type -> StateT DTState Identity (Type, Ident))
-> (Type -> Type) -> Type -> StateT DTState Identity (Type, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
instType) [[Type]]
methodDictTyss
  let patternVs :: [(Type, Ident)]
patternVs   = [(Type, Ident)]
superDictVs [(Type, Ident)] -> [(Type, Ident)] -> [(Type, Ident)]
forall a. [a] -> [a] -> [a]
++ [(Type, Ident)]
methodVs
      pattern :: Pattern Type
pattern     = Type -> QualIdent -> [(Type, Ident)] -> Pattern Type
forall a. a -> QualIdent -> [(a, Ident)] -> Pattern a
createDictPattern (Type -> Type
instType Type
dictTy) QualIdent
ocls [(Type, Ident)]
patternVs
      superStubs :: [Decl Type]
superStubs  = (Type -> QualIdent -> (Type, Ident) -> Decl Type)
-> [Type] -> AugmentEnv -> [(Type, Ident)] -> [Decl Type]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (Pattern Type
-> QualIdent -> Type -> QualIdent -> (Type, Ident) -> Decl Type
forall a.
Pattern a -> QualIdent -> a -> QualIdent -> (a, Ident) -> Decl a
createSuperDictStubDecl Pattern Type
pattern QualIdent
ocls)
                      [Type]
superStubTys AugmentEnv
sclss [(Type, Ident)]
superDictVs
      methodStubs :: [Decl Type]
methodStubs = (Type -> Ident -> (Type, Ident) -> [(Type, Ident)] -> Decl Type)
-> [Type]
-> [Ident]
-> [(Type, Ident)]
-> [[(Type, Ident)]]
-> [Decl Type]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 (Pattern Type
-> Type -> Ident -> (Type, Ident) -> [(Type, Ident)] -> Decl Type
forall a.
Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)] -> Decl a
createMethodStubDecl Pattern Type
pattern)
                      [Type]
methodStubTys [Ident]
fs [(Type, Ident)]
methodVs [[(Type, Ident)]]
methodDictVss
  [Decl Type] -> DTM [Decl Type]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl Type] -> DTM [Decl Type]) -> [Decl Type] -> DTM [Decl Type]
forall a b. (a -> b) -> a -> b
$ [Decl Type]
superStubs [Decl Type] -> [Decl Type] -> [Decl Type]
forall a. [a] -> [a] -> [a]
++ [Decl Type]
methodStubs
createStubs _ = [Decl Type] -> DTM [Decl Type]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- Computes the additional dictionary arguments of a transformed method type
-- which correspond to the constraints of the original class method's type.

computeMethodDictTypes :: QualIdent -> Ident -> Type -> DTM [Type]
computeMethodDictTypes :: QualIdent -> Ident -> Type -> StateT DTState Identity [Type]
computeMethodDictTypes cls :: QualIdent
cls f :: Ident
f ty :: Type
ty = do
  PredType _ ty' :: Type
ty' <- QualIdent -> Ident -> StateT DTState Identity PredType
getClassMethodType QualIdent
cls Ident
f
  [Type] -> StateT DTState Identity [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> StateT DTState Identity [Type])
-> [Type] -> StateT DTState Identity [Type]
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys Int -> Int -> Int
forall a. Num a => a -> a -> a
- Type -> Int
arrowArity Type
ty') [Type]
tys
  where tys :: [Type]
tys = Type -> [Type]
arrowArgs Type
ty

createDictPattern :: a -> QualIdent -> [(a, Ident)] -> Pattern a
createDictPattern :: a -> QualIdent -> [(a, Ident)] -> Pattern a
createDictPattern a :: a
a cls :: QualIdent
cls = a -> QualIdent -> [(a, Ident)] -> Pattern a
forall a. a -> QualIdent -> [(a, Ident)] -> Pattern a
constrPattern a
a (QualIdent -> QualIdent
qDictConstrId QualIdent
cls)

createSuperDictStubDecl :: Pattern a -> QualIdent -> a -> QualIdent
                        -> (a, Ident) -> Decl a
createSuperDictStubDecl :: Pattern a -> QualIdent -> a -> QualIdent -> (a, Ident) -> Decl a
createSuperDictStubDecl t :: Pattern a
t cls :: QualIdent
cls a :: a
a super :: QualIdent
super v :: (a, Ident)
v =
  Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)] -> Decl a
forall a.
Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)] -> Decl a
createStubDecl Pattern a
t a
a (QualIdent -> QualIdent -> Ident
superDictStubId QualIdent
cls QualIdent
super) (a, Ident)
v []

createMethodStubDecl :: Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)]
                     -> Decl a
createMethodStubDecl :: Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)] -> Decl a
createMethodStubDecl = Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)] -> Decl a
forall a.
Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)] -> Decl a
createStubDecl

createStubDecl :: Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)]
               -> Decl a
createStubDecl :: Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)] -> Decl a
createStubDecl t :: Pattern a
t a :: a
a f :: Ident
f v :: (a, Ident)
v us :: [(a, Ident)]
us =
  SpanInfo -> a -> Ident -> [Equation a] -> Decl a
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
NoSpanInfo a
a Ident
f [Pattern a -> Ident -> (a, Ident) -> [(a, Ident)] -> Equation a
forall a.
Pattern a -> Ident -> (a, Ident) -> [(a, Ident)] -> Equation a
createStubEquation Pattern a
t Ident
f (a, Ident)
v [(a, Ident)]
us]

createStubEquation :: Pattern a -> Ident -> (a, Ident) -> [(a, Ident)]
                   -> Equation a
createStubEquation :: Pattern a -> Ident -> (a, Ident) -> [(a, Ident)] -> Equation a
createStubEquation t :: Pattern a
t f :: Ident
f v :: (a, Ident)
v us :: [(a, Ident)]
us =
  SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
NoSpanInfo Ident
f (Pattern a
t Pattern a -> [Pattern a] -> [Pattern a]
forall a. a -> [a] -> [a]
: ((a, Ident) -> Pattern a) -> [(a, Ident)] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Ident -> Pattern a) -> (a, Ident) -> Pattern a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> a -> Ident -> Pattern a
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo)) [(a, Ident)]
us) (Expression a -> Equation a) -> Expression a -> Equation a
forall a b. (a -> b) -> a -> b
$
    Expression a -> [Expression a] -> Expression a
forall a. Expression a -> [Expression a] -> Expression a
apply ((a -> Ident -> Expression a) -> (a, Ident) -> Expression a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> Ident -> Expression a
forall a. a -> Ident -> Expression a
mkVar (a, Ident)
v) (((a, Ident) -> Expression a) -> [(a, Ident)] -> [Expression a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Ident -> Expression a) -> (a, Ident) -> Expression a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> Ident -> Expression a
forall a. a -> Ident -> Expression a
mkVar) [(a, Ident)]
us)

superDictStubType :: QualIdent -> QualIdent -> Type -> Type
superDictStubType :: QualIdent -> QualIdent -> Type -> Type
superDictStubType cls :: QualIdent
cls super :: QualIdent
super ty :: Type
ty =
  Type -> Type -> Type
TypeArrow (Pred -> Type
dictType (Pred -> Type) -> Pred -> Type
forall a b. (a -> b) -> a -> b
$ QualIdent -> Type -> Pred
Pred QualIdent
cls Type
ty) (Pred -> Type
dictType (Pred -> Type) -> Pred -> Type
forall a b. (a -> b) -> a -> b
$ QualIdent -> Type -> Pred
Pred QualIdent
super Type
ty)

-- -----------------------------------------------------------------------------
-- Entering new bindings into the environments
-- -----------------------------------------------------------------------------

bindDictTypes :: ModuleIdent -> ClassEnv -> TCEnv -> TCEnv
bindDictTypes :: ModuleIdent -> ClassEnv -> TCEnv -> TCEnv
bindDictTypes m :: ModuleIdent
m clsEnv :: ClassEnv
clsEnv tcEnv :: TCEnv
tcEnv =
  (TypeInfo -> TCEnv -> TCEnv) -> TCEnv -> [TypeInfo] -> TCEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> ClassEnv -> TypeInfo -> TCEnv -> TCEnv
bindDictType ModuleIdent
m ClassEnv
clsEnv) TCEnv
tcEnv (TCEnv -> [TypeInfo]
forall a. TopEnv a -> [a]
allEntities TCEnv
tcEnv)

bindDictType :: ModuleIdent -> ClassEnv -> TypeInfo -> TCEnv -> TCEnv
bindDictType :: ModuleIdent -> ClassEnv -> TypeInfo -> TCEnv -> TCEnv
bindDictType m :: ModuleIdent
m clsEnv :: ClassEnv
clsEnv (TypeClass cls :: QualIdent
cls k :: Kind
k ms :: [ClassMethod]
ms) = ModuleIdent -> QualIdent -> TypeInfo -> TCEnv -> TCEnv
forall a.
Entity a =>
ModuleIdent -> QualIdent -> a -> TopEnv a -> TopEnv a
bindEntity ModuleIdent
m QualIdent
tc TypeInfo
ti
  where ti :: TypeInfo
ti    = QualIdent -> Kind -> [DataConstr] -> TypeInfo
DataType QualIdent
tc (Kind -> Kind -> Kind
KindArrow Kind
k Kind
KindStar) [DataConstr
c]
        tc :: QualIdent
tc    = QualIdent -> QualIdent
qDictTypeId QualIdent
cls
        c :: DataConstr
c     = Ident -> [Type] -> DataConstr
DataConstr (QualIdent -> Ident
dictConstrId QualIdent
cls) ((Pred -> Type) -> [Pred] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Pred -> Type
dictType (PredSet -> [Pred]
forall a. Set a -> [a]
Set.toAscList PredSet
ps) [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
tys)
        sclss :: AugmentEnv
sclss = QualIdent -> ClassEnv -> AugmentEnv
superClasses QualIdent
cls ClassEnv
clsEnv
        ps :: PredSet
ps    = [Pred] -> PredSet
forall a. Ord a => [a] -> Set a
Set.fromList [QualIdent -> Type -> Pred
Pred QualIdent
scls (Int -> Type
TypeVariable 0) | QualIdent
scls <- AugmentEnv
sclss]
        tys :: [Type]
tys   = (ClassMethod -> Type) -> [ClassMethod] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type
generalizeMethodType (Type -> Type) -> (ClassMethod -> Type) -> ClassMethod -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredType -> Type
transformMethodPredType (PredType -> Type)
-> (ClassMethod -> PredType) -> ClassMethod -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassMethod -> PredType
methodType) [ClassMethod]
ms
bindDictType _ _      _                    = TCEnv -> TCEnv
forall a. a -> a
id

bindClassDecls :: ModuleIdent -> TCEnv -> ClassEnv -> ValueEnv -> ValueEnv
bindClassDecls :: ModuleIdent -> TCEnv -> ClassEnv -> ValueEnv -> ValueEnv
bindClassDecls m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv =
  (ValueEnv -> [TypeInfo] -> ValueEnv)
-> [TypeInfo] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((TypeInfo -> ValueEnv -> ValueEnv)
-> ValueEnv -> [TypeInfo] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((TypeInfo -> ValueEnv -> ValueEnv)
 -> ValueEnv -> [TypeInfo] -> ValueEnv)
-> (TypeInfo -> ValueEnv -> ValueEnv)
-> ValueEnv
-> [TypeInfo]
-> ValueEnv
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> ClassEnv -> TypeInfo -> ValueEnv -> ValueEnv
bindClassEntities ModuleIdent
m ClassEnv
clsEnv) ([TypeInfo] -> ValueEnv -> ValueEnv)
-> [TypeInfo] -> ValueEnv -> ValueEnv
forall a b. (a -> b) -> a -> b
$ TCEnv -> [TypeInfo]
forall a. TopEnv a -> [a]
allEntities TCEnv
tcEnv

-- It is safe to use 'fromMaybe 0' in 'bindClassEntities', because the
-- augmentation has already replaced the 'Nothing' value for the arity
-- of a method's implementation with 'Just 1' (despite the fact that
-- maybe no default implementation has been provided) if the method has
-- been augmented.

bindClassEntities :: ModuleIdent -> ClassEnv -> TypeInfo -> ValueEnv -> ValueEnv
bindClassEntities :: ModuleIdent -> ClassEnv -> TypeInfo -> ValueEnv -> ValueEnv
bindClassEntities m :: ModuleIdent
m clsEnv :: ClassEnv
clsEnv (TypeClass cls :: QualIdent
cls _ ms :: [ClassMethod]
ms) =
  ModuleIdent -> ClassEnv -> QualIdent -> ValueEnv -> ValueEnv
bindClassDict ModuleIdent
m ClassEnv
clsEnv QualIdent
cls (ValueEnv -> ValueEnv)
-> (ValueEnv -> ValueEnv) -> ValueEnv -> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> QualIdent -> AugmentEnv -> ValueEnv -> ValueEnv
bindSuperStubs ModuleIdent
m QualIdent
cls AugmentEnv
sclss (ValueEnv -> ValueEnv)
-> (ValueEnv -> ValueEnv) -> ValueEnv -> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ModuleIdent -> QualIdent -> [(Ident, Int)] -> ValueEnv -> ValueEnv
bindDefaultMethods ModuleIdent
m QualIdent
cls [(Ident, Int)]
fs
  where fs :: [(Ident, Int)]
fs    = [Ident] -> [Int] -> [(Ident, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((ClassMethod -> Ident) -> [ClassMethod] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map ClassMethod -> Ident
methodName [ClassMethod]
ms) ((ClassMethod -> Int) -> [ClassMethod] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 0 (Maybe Int -> Int)
-> (ClassMethod -> Maybe Int) -> ClassMethod -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassMethod -> Maybe Int
methodArity) [ClassMethod]
ms)
        sclss :: AugmentEnv
sclss = QualIdent -> ClassEnv -> AugmentEnv
superClasses QualIdent
cls ClassEnv
clsEnv
bindClassEntities _ _ _ = ValueEnv -> ValueEnv
forall a. a -> a
id

bindClassDict :: ModuleIdent -> ClassEnv -> QualIdent -> ValueEnv -> ValueEnv
bindClassDict :: ModuleIdent -> ClassEnv -> QualIdent -> ValueEnv -> ValueEnv
bindClassDict m :: ModuleIdent
m clsEnv :: ClassEnv
clsEnv cls :: QualIdent
cls vEnv :: ValueEnv
vEnv = ModuleIdent -> QualIdent -> ValueInfo -> ValueEnv -> ValueEnv
forall a.
Entity a =>
ModuleIdent -> QualIdent -> a -> TopEnv a -> TopEnv a
bindEntity ModuleIdent
m QualIdent
c ValueInfo
dc ValueEnv
vEnv
  where c :: QualIdent
c  = QualIdent -> QualIdent
qDictConstrId QualIdent
cls
        dc :: ValueInfo
dc = QualIdent -> Int -> [Ident] -> TypeScheme -> ValueInfo
DataConstructor QualIdent
c Int
a (Int -> Ident -> [Ident]
forall a. Int -> a -> [a]
replicate Int
a Ident
anonId) TypeScheme
tySc
        a :: Int
a  = PredSet -> Int
forall a. Set a -> Int
Set.size PredSet
ps Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
arrowArity Type
ty
        pty :: PredType
pty@(PredType ps :: PredSet
ps ty :: Type
ty) = ValueEnv -> ClassEnv -> QualIdent -> PredType
classDictConstrPredType ValueEnv
vEnv ClassEnv
clsEnv QualIdent
cls
        tySc :: TypeScheme
tySc = Int -> PredType -> TypeScheme
ForAll 1 PredType
pty

bindDefaultMethods :: ModuleIdent -> QualIdent -> [(Ident, Int)] -> ValueEnv
                   -> ValueEnv
bindDefaultMethods :: ModuleIdent -> QualIdent -> [(Ident, Int)] -> ValueEnv -> ValueEnv
bindDefaultMethods m :: ModuleIdent
m = (ValueEnv -> [(Ident, Int)] -> ValueEnv)
-> [(Ident, Int)] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ValueEnv -> [(Ident, Int)] -> ValueEnv)
 -> [(Ident, Int)] -> ValueEnv -> ValueEnv)
-> (QualIdent -> ValueEnv -> [(Ident, Int)] -> ValueEnv)
-> QualIdent
-> [(Ident, Int)]
-> ValueEnv
-> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Ident, Int) -> ValueEnv -> ValueEnv)
-> ValueEnv -> [(Ident, Int)] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((Ident, Int) -> ValueEnv -> ValueEnv)
 -> ValueEnv -> [(Ident, Int)] -> ValueEnv)
-> (QualIdent -> (Ident, Int) -> ValueEnv -> ValueEnv)
-> QualIdent
-> ValueEnv
-> [(Ident, Int)]
-> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> QualIdent -> (Ident, Int) -> ValueEnv -> ValueEnv
bindDefaultMethod ModuleIdent
m

bindDefaultMethod :: ModuleIdent -> QualIdent -> (Ident, Int) -> ValueEnv
                  -> ValueEnv
bindDefaultMethod :: ModuleIdent -> QualIdent -> (Ident, Int) -> ValueEnv -> ValueEnv
bindDefaultMethod m :: ModuleIdent
m cls :: QualIdent
cls (f :: Ident
f, n :: Int
n) vEnv :: ValueEnv
vEnv =
  ModuleIdent -> QualIdent -> Int -> PredType -> ValueEnv -> ValueEnv
bindMethod ModuleIdent
m (QualIdent -> Ident -> QualIdent
qDefaultMethodId QualIdent
cls Ident
f) Int
n (ValueEnv -> QualIdent -> Ident -> PredType
classMethodType ValueEnv
vEnv QualIdent
cls Ident
f) ValueEnv
vEnv

bindSuperStubs :: ModuleIdent -> QualIdent -> [QualIdent] -> ValueEnv
               -> ValueEnv
bindSuperStubs :: ModuleIdent -> QualIdent -> AugmentEnv -> ValueEnv -> ValueEnv
bindSuperStubs m :: ModuleIdent
m = (ValueEnv -> AugmentEnv -> ValueEnv)
-> AugmentEnv -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ValueEnv -> AugmentEnv -> ValueEnv)
 -> AugmentEnv -> ValueEnv -> ValueEnv)
-> (QualIdent -> ValueEnv -> AugmentEnv -> ValueEnv)
-> QualIdent
-> AugmentEnv
-> ValueEnv
-> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualIdent -> ValueEnv -> ValueEnv)
-> ValueEnv -> AugmentEnv -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((QualIdent -> ValueEnv -> ValueEnv)
 -> ValueEnv -> AugmentEnv -> ValueEnv)
-> (QualIdent -> QualIdent -> ValueEnv -> ValueEnv)
-> QualIdent
-> ValueEnv
-> AugmentEnv
-> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> QualIdent -> QualIdent -> ValueEnv -> ValueEnv
bindSuperStub ModuleIdent
m

bindSuperStub :: ModuleIdent -> QualIdent -> QualIdent -> ValueEnv -> ValueEnv
bindSuperStub :: ModuleIdent -> QualIdent -> QualIdent -> ValueEnv -> ValueEnv
bindSuperStub m :: ModuleIdent
m cls :: QualIdent
cls scls :: QualIdent
scls = ModuleIdent -> QualIdent -> ValueInfo -> ValueEnv -> ValueEnv
forall a.
Entity a =>
ModuleIdent -> QualIdent -> a -> TopEnv a -> TopEnv a
bindEntity ModuleIdent
m QualIdent
f (ValueInfo -> ValueEnv -> ValueEnv)
-> ValueInfo -> ValueEnv -> ValueEnv
forall a b. (a -> b) -> a -> b
$ QualIdent -> Bool -> Int -> TypeScheme -> ValueInfo
Value QualIdent
f Bool
False 1 (TypeScheme -> ValueInfo) -> TypeScheme -> ValueInfo
forall a b. (a -> b) -> a -> b
$ Type -> TypeScheme
polyType Type
ty
  where f :: QualIdent
f  = QualIdent -> QualIdent -> QualIdent
qSuperDictStubId QualIdent
cls QualIdent
scls
        ty :: Type
ty = QualIdent -> QualIdent -> Type -> Type
superDictStubType QualIdent
cls QualIdent
scls (Int -> Type
TypeVariable 0)

bindInstDecls :: ModuleIdent -> TCEnv -> ClassEnv -> InstEnv -> ValueEnv
                  -> ValueEnv
bindInstDecls :: ModuleIdent -> TCEnv -> ClassEnv -> InstEnv -> ValueEnv -> ValueEnv
bindInstDecls m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv =
  (ValueEnv -> [(InstIdent, InstInfo)] -> ValueEnv)
-> [(InstIdent, InstInfo)] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((InstIdent, InstInfo) -> ValueEnv -> ValueEnv)
-> ValueEnv -> [(InstIdent, InstInfo)] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((InstIdent, InstInfo) -> ValueEnv -> ValueEnv)
 -> ValueEnv -> [(InstIdent, InstInfo)] -> ValueEnv)
-> ((InstIdent, InstInfo) -> ValueEnv -> ValueEnv)
-> ValueEnv
-> [(InstIdent, InstInfo)]
-> ValueEnv
forall a b. (a -> b) -> a -> b
$ ModuleIdent
-> TCEnv
-> ClassEnv
-> (InstIdent, InstInfo)
-> ValueEnv
-> ValueEnv
bindInstFuns ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv) ([(InstIdent, InstInfo)] -> ValueEnv -> ValueEnv)
-> (InstEnv -> [(InstIdent, InstInfo)])
-> InstEnv
-> ValueEnv
-> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstEnv -> [(InstIdent, InstInfo)]
forall k a. Map k a -> [(k, a)]
Map.toList

bindInstFuns :: ModuleIdent -> TCEnv -> ClassEnv -> (InstIdent, InstInfo)
             -> ValueEnv -> ValueEnv
bindInstFuns :: ModuleIdent
-> TCEnv
-> ClassEnv
-> (InstIdent, InstInfo)
-> ValueEnv
-> ValueEnv
bindInstFuns m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv ((cls :: QualIdent
cls, tc :: QualIdent
tc), (m' :: ModuleIdent
m', ps :: PredSet
ps, is :: [(Ident, Int)]
is)) =
  ModuleIdent
-> QualIdent
-> Type
-> ModuleIdent
-> PredSet
-> ValueEnv
-> ValueEnv
bindInstDict ModuleIdent
m QualIdent
cls Type
ty ModuleIdent
m' PredSet
ps (ValueEnv -> ValueEnv)
-> (ValueEnv -> ValueEnv) -> ValueEnv -> ValueEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent
-> ClassEnv
-> QualIdent
-> Type
-> ModuleIdent
-> PredSet
-> [(Ident, Int)]
-> ValueEnv
-> ValueEnv
bindInstMethods ModuleIdent
m ClassEnv
clsEnv QualIdent
cls Type
ty ModuleIdent
m' PredSet
ps [(Ident, Int)]
is
  where ty :: Type
ty = Type -> [Type] -> Type
applyType (QualIdent -> Type
TypeConstructor QualIdent
tc) (Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
take Int
n ((Int -> Type) -> [Int] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Type
TypeVariable [0..]))
        n :: Int
n = Kind -> Int
kindArity (ModuleIdent -> QualIdent -> TCEnv -> Kind
tcKind ModuleIdent
m QualIdent
tc TCEnv
tcEnv) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Kind -> Int
kindArity (ModuleIdent -> QualIdent -> TCEnv -> Kind
clsKind ModuleIdent
m QualIdent
cls TCEnv
tcEnv)

bindInstDict :: ModuleIdent -> QualIdent -> Type -> ModuleIdent -> PredSet
             -> ValueEnv -> ValueEnv
bindInstDict :: ModuleIdent
-> QualIdent
-> Type
-> ModuleIdent
-> PredSet
-> ValueEnv
-> ValueEnv
bindInstDict m :: ModuleIdent
m cls :: QualIdent
cls ty :: Type
ty m' :: ModuleIdent
m' ps :: PredSet
ps =
  ModuleIdent -> QualIdent -> Int -> PredType -> ValueEnv -> ValueEnv
bindMethod ModuleIdent
m (ModuleIdent -> QualIdent -> Type -> QualIdent
qInstFunId ModuleIdent
m' QualIdent
cls Type
ty) 0 (PredType -> ValueEnv -> ValueEnv)
-> PredType -> ValueEnv -> ValueEnv
forall a b. (a -> b) -> a -> b
$ PredSet -> Type -> PredType
PredType PredSet
ps (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Pred -> Type
dictType (Pred -> Type) -> Pred -> Type
forall a b. (a -> b) -> a -> b
$ QualIdent -> Type -> Pred
Pred QualIdent
cls Type
ty

bindInstMethods :: ModuleIdent -> ClassEnv -> QualIdent -> Type -> ModuleIdent
                -> PredSet -> [(Ident, Int)] -> ValueEnv -> ValueEnv
bindInstMethods :: ModuleIdent
-> ClassEnv
-> QualIdent
-> Type
-> ModuleIdent
-> PredSet
-> [(Ident, Int)]
-> ValueEnv
-> ValueEnv
bindInstMethods m :: ModuleIdent
m clsEnv :: ClassEnv
clsEnv cls :: QualIdent
cls ty :: Type
ty m' :: ModuleIdent
m' ps :: PredSet
ps is :: [(Ident, Int)]
is =
  (ValueEnv -> [Ident] -> ValueEnv)
-> [Ident] -> ValueEnv -> ValueEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ident -> ValueEnv -> ValueEnv) -> ValueEnv -> [Ident] -> ValueEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent
-> QualIdent
-> Type
-> ModuleIdent
-> PredSet
-> [(Ident, Int)]
-> Ident
-> ValueEnv
-> ValueEnv
bindInstMethod ModuleIdent
m QualIdent
cls Type
ty ModuleIdent
m' PredSet
ps [(Ident, Int)]
is)) (QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
cls ClassEnv
clsEnv)

bindInstMethod :: ModuleIdent -> QualIdent -> Type -> ModuleIdent
               -> PredSet -> [(Ident, Int)] -> Ident -> ValueEnv -> ValueEnv
bindInstMethod :: ModuleIdent
-> QualIdent
-> Type
-> ModuleIdent
-> PredSet
-> [(Ident, Int)]
-> Ident
-> ValueEnv
-> ValueEnv
bindInstMethod m :: ModuleIdent
m cls :: QualIdent
cls ty :: Type
ty m' :: ModuleIdent
m' ps :: PredSet
ps is :: [(Ident, Int)]
is f :: Ident
f vEnv :: ValueEnv
vEnv = ModuleIdent -> QualIdent -> Int -> PredType -> ValueEnv -> ValueEnv
bindMethod ModuleIdent
m QualIdent
f' Int
a PredType
pty ValueEnv
vEnv
  where f' :: QualIdent
f'  = ModuleIdent -> QualIdent -> Type -> Ident -> QualIdent
qImplMethodId ModuleIdent
m' QualIdent
cls Type
ty Ident
f
        a :: Int
a   = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Ident -> [(Ident, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
f [(Ident, Int)]
is
        pty :: PredType
pty = ValueEnv -> PredSet -> QualIdent -> Type -> Ident -> PredType
instMethodType ValueEnv
vEnv PredSet
ps QualIdent
cls Type
ty Ident
f

bindMethod :: ModuleIdent -> QualIdent -> Int -> PredType -> ValueEnv
           -> ValueEnv
bindMethod :: ModuleIdent -> QualIdent -> Int -> PredType -> ValueEnv -> ValueEnv
bindMethod m :: ModuleIdent
m f :: QualIdent
f n :: Int
n pty :: PredType
pty = ModuleIdent -> QualIdent -> ValueInfo -> ValueEnv -> ValueEnv
forall a.
Entity a =>
ModuleIdent -> QualIdent -> a -> TopEnv a -> TopEnv a
bindEntity ModuleIdent
m QualIdent
f (ValueInfo -> ValueEnv -> ValueEnv)
-> ValueInfo -> ValueEnv -> ValueEnv
forall a b. (a -> b) -> a -> b
$ QualIdent -> Bool -> Int -> TypeScheme -> ValueInfo
Value QualIdent
f Bool
False Int
n (TypeScheme -> ValueInfo) -> TypeScheme -> ValueInfo
forall a b. (a -> b) -> a -> b
$ PredType -> TypeScheme
typeScheme PredType
pty

-- The function 'bindEntity' introduces a binding for an entity into a top-level
-- environment. Depending on whether the entity is defined in the current module
-- or not, either an unqualified and a qualified local binding or a qualified
-- import are added to the environment.

bindEntity :: Entity a => ModuleIdent -> QualIdent -> a -> TopEnv a
           -> TopEnv a
bindEntity :: ModuleIdent -> QualIdent -> a -> TopEnv a -> TopEnv a
bindEntity m :: ModuleIdent
m x :: QualIdent
x = case QualIdent -> Maybe ModuleIdent
qidModule (ModuleIdent -> QualIdent -> QualIdent
qualUnqualify ModuleIdent
m QualIdent
x) of
  Just m' :: ModuleIdent
m' | ModuleIdent
m ModuleIdent -> ModuleIdent -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleIdent
m' -> ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a
forall a.
Entity a =>
ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a
qualImportTopEnv ModuleIdent
m' Ident
x'
  _                 -> QualIdent -> a -> TopEnv a -> TopEnv a
forall a. QualIdent -> a -> TopEnv a -> TopEnv a
qualBindTopEnv (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
x')
  where x' :: Ident
x' = QualIdent -> Ident
unqualify QualIdent
x

-- -----------------------------------------------------------------------------
-- Transforming the environments
-- -----------------------------------------------------------------------------

dictTransTypes :: TCEnv -> TCEnv
dictTransTypes :: TCEnv -> TCEnv
dictTransTypes = (TypeInfo -> TypeInfo) -> TCEnv -> TCEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeInfo -> TypeInfo
dictTransTypeInfo

dictTransTypeInfo :: TypeInfo -> TypeInfo
dictTransTypeInfo :: TypeInfo -> TypeInfo
dictTransTypeInfo (DataType tc :: QualIdent
tc k :: Kind
k cs :: [DataConstr]
cs) =
  QualIdent -> Kind -> [DataConstr] -> TypeInfo
DataType QualIdent
tc Kind
k ([DataConstr] -> TypeInfo) -> [DataConstr] -> TypeInfo
forall a b. (a -> b) -> a -> b
$ (DataConstr -> DataConstr) -> [DataConstr] -> [DataConstr]
forall a b. (a -> b) -> [a] -> [b]
map DataConstr -> DataConstr
dictTransDataConstr [DataConstr]
cs
dictTransTypeInfo (RenamingType tc :: QualIdent
tc k :: Kind
k nc :: DataConstr
nc) =
  QualIdent -> Kind -> DataConstr -> TypeInfo
RenamingType QualIdent
tc Kind
k (DataConstr -> TypeInfo) -> DataConstr -> TypeInfo
forall a b. (a -> b) -> a -> b
$ DataConstr -> DataConstr
dictTransDataConstr DataConstr
nc
dictTransTypeInfo ti :: TypeInfo
ti@(AliasType _ _ _ _) = TypeInfo
ti
dictTransTypeInfo (TypeClass cls :: QualIdent
cls k :: Kind
k ms :: [ClassMethod]
ms) =
  QualIdent -> Kind -> [ClassMethod] -> TypeInfo
TypeClass QualIdent
cls Kind
k ([ClassMethod] -> TypeInfo) -> [ClassMethod] -> TypeInfo
forall a b. (a -> b) -> a -> b
$ (ClassMethod -> ClassMethod) -> [ClassMethod] -> [ClassMethod]
forall a b. (a -> b) -> [a] -> [b]
map ClassMethod -> ClassMethod
dictTransClassMethod [ClassMethod]
ms
dictTransTypeInfo (TypeVar _) =
  String -> TypeInfo
forall a. String -> a
internalError "Dictionary.dictTransTypeInfo: type variable"

dictTransDataConstr :: DataConstr -> DataConstr
dictTransDataConstr :: DataConstr -> DataConstr
dictTransDataConstr (DataConstr c :: Ident
c tys :: [Type]
tys) = Ident -> [Type] -> DataConstr
DataConstr Ident
c [Type]
tys
dictTransDataConstr (RecordConstr c :: Ident
c _ tys :: [Type]
tys) =
  DataConstr -> DataConstr
dictTransDataConstr (DataConstr -> DataConstr) -> DataConstr -> DataConstr
forall a b. (a -> b) -> a -> b
$ Ident -> [Type] -> DataConstr
DataConstr Ident
c [Type]
tys

-- For the same reason as in 'bindClassEntities' it is safe to use 'fromMaybe 0'
-- in 'dictTransClassMethod'. Note that type classes are removed anyway in the
-- cleanup phase.

dictTransClassMethod :: ClassMethod -> ClassMethod
dictTransClassMethod :: ClassMethod -> ClassMethod
dictTransClassMethod (ClassMethod f :: Ident
f a :: Maybe Int
a pty :: PredType
pty) = Ident -> Maybe Int -> PredType -> ClassMethod
ClassMethod Ident
f Maybe Int
a' (PredType -> ClassMethod) -> PredType -> ClassMethod
forall a b. (a -> b) -> a -> b
$ Type -> PredType
predType Type
ty
  where a' :: Maybe Int
a' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 0 Maybe Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Int
arrowArity Type
ty Int -> Int -> Int
forall a. Num a => a -> a -> a
- Type -> Int
arrowArity (PredType -> Type
unpredType PredType
pty)
        ty :: Type
ty = PredType -> Type
transformPredType PredType
pty

dictTransValues :: ValueEnv -> ValueEnv
dictTransValues :: ValueEnv -> ValueEnv
dictTransValues = (ValueInfo -> ValueInfo) -> ValueEnv -> ValueEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValueInfo -> ValueInfo
dictTransValueInfo

dictTransValueInfo :: ValueInfo -> ValueInfo
dictTransValueInfo :: ValueInfo -> ValueInfo
dictTransValueInfo (DataConstructor c :: QualIdent
c a :: Int
a ls :: [Ident]
ls (ForAll n :: Int
n pty :: PredType
pty)) =
  QualIdent -> Int -> [Ident] -> TypeScheme -> ValueInfo
DataConstructor QualIdent
c Int
a' [Ident]
ls' (TypeScheme -> ValueInfo) -> TypeScheme -> ValueInfo
forall a b. (a -> b) -> a -> b
$ Int -> PredType -> TypeScheme
ForAll Int
n (PredType -> TypeScheme) -> PredType -> TypeScheme
forall a b. (a -> b) -> a -> b
$ Type -> PredType
predType Type
ty
  where a' :: Int
a'  = Type -> Int
arrowArity Type
ty
        ls' :: [Ident]
ls' = Int -> Ident -> [Ident]
forall a. Int -> a -> [a]
replicate (Int
a' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
a) Ident
anonId [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [Ident]
ls
        ty :: Type
ty  = PredType -> Type
transformPredType PredType
pty
dictTransValueInfo (NewtypeConstructor c :: QualIdent
c l :: Ident
l (ForAll n :: Int
n pty :: PredType
pty)) =
  QualIdent -> Ident -> TypeScheme -> ValueInfo
NewtypeConstructor QualIdent
c Ident
l (Int -> PredType -> TypeScheme
ForAll Int
n (Type -> PredType
predType (PredType -> Type
unpredType PredType
pty)))
dictTransValueInfo (Value f :: QualIdent
f cm :: Bool
cm a :: Int
a (ForAll n :: Int
n pty :: PredType
pty)) =
  QualIdent -> Bool -> Int -> TypeScheme -> ValueInfo
Value QualIdent
f Bool
False Int
a' (TypeScheme -> ValueInfo) -> TypeScheme -> ValueInfo
forall a b. (a -> b) -> a -> b
$ Int -> PredType -> TypeScheme
ForAll Int
n (PredType -> TypeScheme) -> PredType -> TypeScheme
forall a b. (a -> b) -> a -> b
$ Type -> PredType
predType Type
ty
  where a' :: Int
a' = Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Bool
cm then 1 else Type -> Int
arrowArity Type
ty Int -> Int -> Int
forall a. Num a => a -> a -> a
- Type -> Int
arrowArity (PredType -> Type
unpredType PredType
pty)
        ty :: Type
ty = PredType -> Type
transformPredType PredType
pty
dictTransValueInfo (Label l :: QualIdent
l cs :: AugmentEnv
cs (ForAll n :: Int
n pty :: PredType
pty)) =
  QualIdent -> AugmentEnv -> TypeScheme -> ValueInfo
Label QualIdent
l AugmentEnv
cs (TypeScheme -> ValueInfo) -> TypeScheme -> ValueInfo
forall a b. (a -> b) -> a -> b
$ Int -> PredType -> TypeScheme
ForAll Int
n (PredType -> TypeScheme) -> PredType -> TypeScheme
forall a b. (a -> b) -> a -> b
$ Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty

-- -----------------------------------------------------------------------------
-- Adding exports
-- -----------------------------------------------------------------------------

addExports :: Maybe ExportSpec -> [Export] -> Maybe ExportSpec
addExports :: Maybe ExportSpec -> [Export] -> Maybe ExportSpec
addExports (Just (Exporting p :: SpanInfo
p es :: [Export]
es)) es' :: [Export]
es' = ExportSpec -> Maybe ExportSpec
forall a. a -> Maybe a
Just (ExportSpec -> Maybe ExportSpec) -> ExportSpec -> Maybe ExportSpec
forall a b. (a -> b) -> a -> b
$ SpanInfo -> [Export] -> ExportSpec
Exporting SpanInfo
p ([Export] -> ExportSpec) -> [Export] -> ExportSpec
forall a b. (a -> b) -> a -> b
$ [Export]
es [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++ [Export]
es'
addExports Nothing                 _   = String -> Maybe ExportSpec
forall a. String -> a
internalError "Dictionary.addExports"

dictExports :: Decl a -> DTM [Export]
dictExports :: Decl a -> DTM [Export]
dictExports (ClassDecl _ _ cls :: Ident
cls _ _) = do
  ModuleIdent
m <- DTM ModuleIdent
getModuleIdent
  ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
  [Export] -> DTM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Export] -> DTM [Export]) -> [Export] -> DTM [Export]
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> ClassEnv -> Ident -> [Export]
classExports ModuleIdent
m ClassEnv
clsEnv Ident
cls
dictExports (InstanceDecl _ _ cls :: QualIdent
cls ty :: InstanceType
ty _) = do
  ModuleIdent
m <- DTM ModuleIdent
getModuleIdent
  ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
  [Export] -> DTM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Export] -> DTM [Export]) -> [Export] -> DTM [Export]
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> ClassEnv -> QualIdent -> Type -> [Export]
instExports ModuleIdent
m ClassEnv
clsEnv QualIdent
cls ([Ident] -> InstanceType -> Type
toType [] InstanceType
ty)
dictExports _ = [Export] -> DTM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return []

classExports :: ModuleIdent -> ClassEnv -> Ident -> [Export]
classExports :: ModuleIdent -> ClassEnv -> Ident -> [Export]
classExports m :: ModuleIdent
m clsEnv :: ClassEnv
clsEnv cls :: Ident
cls =
  SpanInfo -> QualIdent -> [Ident] -> Export
ExportTypeWith SpanInfo
NoSpanInfo (QualIdent -> QualIdent
qDictTypeId QualIdent
qcls) [QualIdent -> Ident
dictConstrId QualIdent
qcls] Export -> [Export] -> [Export]
forall a. a -> [a] -> [a]
:
   (QualIdent -> Export) -> AugmentEnv -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (SpanInfo -> QualIdent -> Export
Export SpanInfo
NoSpanInfo (QualIdent -> Export)
-> (QualIdent -> QualIdent) -> QualIdent -> Export
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> QualIdent -> QualIdent
qSuperDictStubId QualIdent
qcls) (QualIdent -> ClassEnv -> AugmentEnv
superClasses QualIdent
qcls ClassEnv
clsEnv) [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++
    (Ident -> Export) -> [Ident] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (SpanInfo -> QualIdent -> Export
Export SpanInfo
NoSpanInfo (QualIdent -> Export) -> (Ident -> QualIdent) -> Ident -> Export
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> Ident -> QualIdent
qDefaultMethodId QualIdent
qcls) (QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
qcls ClassEnv
clsEnv)
  where qcls :: QualIdent
qcls = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
cls

instExports :: ModuleIdent -> ClassEnv -> QualIdent -> Type -> [Export]
instExports :: ModuleIdent -> ClassEnv -> QualIdent -> Type -> [Export]
instExports m :: ModuleIdent
m clsEnv :: ClassEnv
clsEnv cls :: QualIdent
cls ty :: Type
ty =
  SpanInfo -> QualIdent -> Export
Export SpanInfo
NoSpanInfo (ModuleIdent -> QualIdent -> Type -> QualIdent
qInstFunId ModuleIdent
m QualIdent
cls Type
ty) Export -> [Export] -> [Export]
forall a. a -> [a] -> [a]
:
    (Ident -> Export) -> [Ident] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (SpanInfo -> QualIdent -> Export
Export SpanInfo
NoSpanInfo (QualIdent -> Export) -> (Ident -> QualIdent) -> Ident -> Export
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> QualIdent -> Type -> Ident -> QualIdent
qImplMethodId ModuleIdent
m QualIdent
cls Type
ty) (QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
cls ClassEnv
clsEnv)

-- -----------------------------------------------------------------------------
-- Transforming the module
-- -----------------------------------------------------------------------------

type DictEnv = [(Pred, Expression Type)]

emptyDictEnv :: DictEnv
emptyDictEnv :: DictEnv
emptyDictEnv = []

class DictTrans a where
  dictTrans :: a PredType -> DTM (a Type)

instance DictTrans Module where
  dictTrans :: Module PredType -> DTM (Module Type)
dictTrans (Module spi :: SpanInfo
spi ps :: [ModulePragma]
ps m :: ModuleIdent
m es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl PredType]
ds) = do
    [Decl PredType]
liftedDs <- (Decl PredType -> StateT DTState Identity [Decl PredType])
-> [Decl PredType] -> StateT DTState Identity [Decl PredType]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl PredType -> StateT DTState Identity [Decl PredType]
liftDecls [Decl PredType]
ds
    [Decl Type]
stubDs <- (Decl PredType -> DTM [Decl Type])
-> [Decl PredType] -> DTM [Decl Type]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl PredType -> DTM [Decl Type]
createStubs [Decl PredType]
ds
    TCEnv
tcEnv <- DTM TCEnv
getTyConsEnv
    ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
    InstEnv
inEnv <- DTM InstEnv
getInstEnv
    (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> DTM ())
-> (ValueEnv -> ValueEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> TCEnv -> ClassEnv -> ValueEnv -> ValueEnv
bindClassDecls ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv
    (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> DTM ())
-> (ValueEnv -> ValueEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> TCEnv -> ClassEnv -> InstEnv -> ValueEnv -> ValueEnv
bindInstDecls ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv InstEnv
inEnv
    (TCEnv -> TCEnv) -> DTM ()
modifyTyConsEnv ((TCEnv -> TCEnv) -> DTM ()) -> (TCEnv -> TCEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> ClassEnv -> TCEnv -> TCEnv
bindDictTypes ModuleIdent
m ClassEnv
clsEnv
    [Decl Type]
transDs <- (Decl PredType -> StateT DTState Identity (Decl Type))
-> [Decl PredType] -> DTM [Decl Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl PredType -> StateT DTState Identity (Decl Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans [Decl PredType]
liftedDs
    (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> DTM ())
-> (ValueEnv -> ValueEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ ValueEnv -> ValueEnv
dictTransValues
    (TCEnv -> TCEnv) -> DTM ()
modifyTyConsEnv ((TCEnv -> TCEnv) -> DTM ()) -> (TCEnv -> TCEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ TCEnv -> TCEnv
dictTransTypes
    Maybe ExportSpec
dictEs <- Maybe ExportSpec -> [Export] -> Maybe ExportSpec
addExports Maybe ExportSpec
es ([Export] -> Maybe ExportSpec)
-> DTM [Export] -> StateT DTState Identity (Maybe ExportSpec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl PredType -> DTM [Export]) -> [Decl PredType] -> DTM [Export]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl PredType -> DTM [Export]
forall a. Decl a -> DTM [Export]
dictExports [Decl PredType]
ds
    Module Type -> DTM (Module Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module Type -> DTM (Module Type))
-> Module Type -> DTM (Module Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl Type]
-> Module Type
forall a.
SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
Module SpanInfo
spi [ModulePragma]
ps ModuleIdent
m Maybe ExportSpec
dictEs [ImportDecl]
is ([Decl Type] -> Module Type) -> [Decl Type] -> Module Type
forall a b. (a -> b) -> a -> b
$ [Decl Type]
transDs [Decl Type] -> [Decl Type] -> [Decl Type]
forall a. [a] -> [a] -> [a]
++ [Decl Type]
stubDs

-- We use and transform the type from the type constructor environment for
-- transforming a constructor declaration as it contains the reduced and
-- restricted predicate set for each data constructor.

-- The pattern declaration case of the DictTrans Decl instance converts
-- variable declarations with an overloaded type into function declarations.
-- This is necessary so that the compiler can add the implicit dictionary
-- arguments to the declaration.

instance DictTrans Decl where
  dictTrans :: Decl PredType -> StateT DTState Identity (Decl Type)
dictTrans (InfixDecl      p :: SpanInfo
p fix :: Infix
fix prec :: Maybe Integer
prec ops :: [Ident]
ops) = Decl Type -> StateT DTState Identity (Decl Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl Type -> StateT DTState Identity (Decl Type))
-> Decl Type -> StateT DTState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Infix -> Maybe Integer -> [Ident] -> Decl Type
forall a. SpanInfo -> Infix -> Maybe Integer -> [Ident] -> Decl a
InfixDecl SpanInfo
p Infix
fix Maybe Integer
prec [Ident]
ops
  dictTrans (DataDecl        p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs _) = do
    ModuleIdent
m <- DTM ModuleIdent
getModuleIdent
    TCEnv
tcEnv <- DTM TCEnv
getTyConsEnv
    let DataType _ _ cs' :: [DataConstr]
cs' = [TypeInfo] -> TypeInfo
forall a. [a] -> a
head ([TypeInfo] -> TypeInfo) -> [TypeInfo] -> TypeInfo
forall a b. (a -> b) -> a -> b
$ QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
tc) TCEnv
tcEnv
    Decl Type -> StateT DTState Identity (Decl Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl Type -> StateT DTState Identity (Decl Type))
-> Decl Type -> StateT DTState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> AugmentEnv -> Decl Type
forall a.
SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> AugmentEnv -> Decl a
DataDecl SpanInfo
p Ident
tc [Ident]
tvs ((ConstrDecl -> DataConstr -> ConstrDecl)
-> [ConstrDecl] -> [DataConstr] -> [ConstrDecl]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([Ident] -> ConstrDecl -> DataConstr -> ConstrDecl
dictTransConstrDecl [Ident]
tvs) [ConstrDecl]
cs [DataConstr]
cs') []
  dictTrans (ExternalDataDecl     p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs) = Decl Type -> StateT DTState Identity (Decl Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl Type -> StateT DTState Identity (Decl Type))
-> Decl Type -> StateT DTState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Ident -> [Ident] -> Decl Type
forall a. SpanInfo -> Ident -> [Ident] -> Decl a
ExternalDataDecl SpanInfo
p Ident
tc [Ident]
tvs
  dictTrans (NewtypeDecl     p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs nc :: NewConstrDecl
nc _) =
    Decl Type -> StateT DTState Identity (Decl Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl Type -> StateT DTState Identity (Decl Type))
-> Decl Type -> StateT DTState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Ident -> [Ident] -> NewConstrDecl -> AugmentEnv -> Decl Type
forall a.
SpanInfo
-> Ident -> [Ident] -> NewConstrDecl -> AugmentEnv -> Decl a
NewtypeDecl SpanInfo
p Ident
tc [Ident]
tvs NewConstrDecl
nc []
  dictTrans (TypeDecl          p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs ty :: InstanceType
ty) = Decl Type -> StateT DTState Identity (Decl Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl Type -> StateT DTState Identity (Decl Type))
-> Decl Type -> StateT DTState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Ident -> [Ident] -> InstanceType -> Decl Type
forall a. SpanInfo -> Ident -> [Ident] -> InstanceType -> Decl a
TypeDecl SpanInfo
p Ident
tc [Ident]
tvs InstanceType
ty
  dictTrans (FunctionDecl p :: SpanInfo
p      pty :: PredType
pty f :: Ident
f eqs :: [Equation PredType]
eqs) =
    SpanInfo -> Type -> Ident -> [Equation Type] -> Decl Type
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p (PredType -> Type
transformPredType PredType
pty) Ident
f ([Equation Type] -> Decl Type)
-> StateT DTState Identity [Equation Type]
-> StateT DTState Identity (Decl Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Equation PredType -> StateT DTState Identity (Equation Type))
-> [Equation PredType] -> StateT DTState Identity [Equation Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Equation PredType -> StateT DTState Identity (Equation Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans [Equation PredType]
eqs
  dictTrans (PatternDecl           p :: SpanInfo
p t :: Pattern PredType
t rhs :: Rhs PredType
rhs) = case Pattern PredType
t of
    VariablePattern _ pty :: PredType
pty@(PredType ps :: PredSet
ps _) v :: Ident
v | Bool -> Bool
not (PredSet -> Bool
forall a. Set a -> Bool
Set.null PredSet
ps) ->
      Decl PredType -> StateT DTState Identity (Decl Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans (Decl PredType -> StateT DTState Identity (Decl Type))
-> Decl PredType -> StateT DTState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p PredType
pty Ident
v [SpanInfo -> Lhs PredType -> Rhs PredType -> Equation PredType
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p (SpanInfo -> Ident -> [Pattern PredType] -> Lhs PredType
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
NoSpanInfo Ident
v []) Rhs PredType
rhs]
    _ -> StateT DTState Identity (Decl Type)
-> StateT DTState Identity (Decl Type)
forall a. DTM a -> DTM a
withLocalDictEnv (StateT DTState Identity (Decl Type)
 -> StateT DTState Identity (Decl Type))
-> StateT DTState Identity (Decl Type)
-> StateT DTState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Pattern Type -> Rhs Type -> Decl Type
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p (Pattern Type -> Rhs Type -> Decl Type)
-> StateT DTState Identity (Pattern Type)
-> StateT DTState Identity (Rhs Type -> Decl Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern PredType -> StateT DTState Identity (Pattern Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Pattern PredType
t StateT DTState Identity (Rhs Type -> Decl Type)
-> StateT DTState Identity (Rhs Type)
-> StateT DTState Identity (Decl Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rhs PredType -> StateT DTState Identity (Rhs Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Rhs PredType
rhs
  dictTrans d :: Decl PredType
d@(FreeDecl                _ _) = Decl Type -> StateT DTState Identity (Decl Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl Type -> StateT DTState Identity (Decl Type))
-> Decl Type -> StateT DTState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ (PredType -> Type) -> Decl PredType -> Decl Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PredType -> Type
unpredType Decl PredType
d
  dictTrans d :: Decl PredType
d@(ExternalDecl            _ _) = Decl Type -> StateT DTState Identity (Decl Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl Type -> StateT DTState Identity (Decl Type))
-> Decl Type -> StateT DTState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ (PredType -> Type) -> Decl PredType -> Decl Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PredType -> Type
unpredType Decl PredType
d
  dictTrans d :: Decl PredType
d                               =
    String -> StateT DTState Identity (Decl Type)
forall a. String -> a
internalError (String -> StateT DTState Identity (Decl Type))
-> String -> StateT DTState Identity (Decl Type)
forall a b. (a -> b) -> a -> b
$ "Dictionary.dictTrans: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Decl PredType -> String
forall a. Show a => a -> String
show Decl PredType
d

dictTransConstrDecl :: [Ident] -> ConstrDecl -> DataConstr -> ConstrDecl
dictTransConstrDecl :: [Ident] -> ConstrDecl -> DataConstr -> ConstrDecl
dictTransConstrDecl tvs :: [Ident]
tvs (ConstrDecl p :: SpanInfo
p c :: Ident
c tes :: [InstanceType]
tes) dc :: DataConstr
dc =
  SpanInfo -> Ident -> [InstanceType] -> ConstrDecl
ConstrDecl SpanInfo
p Ident
c ([InstanceType] -> ConstrDecl) -> [InstanceType] -> ConstrDecl
forall a b. (a -> b) -> a -> b
$ (Type -> InstanceType) -> [Type] -> [InstanceType]
forall a b. (a -> b) -> [a] -> [b]
map ([Ident] -> Type -> InstanceType
fromType ([Ident] -> Type -> InstanceType)
-> [Ident] -> Type -> InstanceType
forall a b. (a -> b) -> a -> b
$ [Ident]
tvs [Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++ [Ident]
bvs) (DataConstr -> [Type]
constrTypes DataConstr
dc)
  where bvs :: [Ident]
bvs = [Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub ([Ident] -> [Ident]) -> [Ident] -> [Ident]
forall a b. (a -> b) -> a -> b
$ [InstanceType] -> [Ident]
forall e. QuantExpr e => e -> [Ident]
bv [InstanceType]
tes
dictTransConstrDecl tvs :: [Ident]
tvs (ConOpDecl p :: SpanInfo
p ty1 :: InstanceType
ty1 op :: Ident
op ty2 :: InstanceType
ty2) dc :: DataConstr
dc =
  [Ident] -> ConstrDecl -> DataConstr -> ConstrDecl
dictTransConstrDecl [Ident]
tvs (SpanInfo -> Ident -> [InstanceType] -> ConstrDecl
ConstrDecl SpanInfo
p Ident
op [InstanceType
ty1, InstanceType
ty2]) DataConstr
dc
dictTransConstrDecl _ d :: ConstrDecl
d _ = String -> ConstrDecl
forall a. String -> a
internalError (String -> ConstrDecl) -> String -> ConstrDecl
forall a b. (a -> b) -> a -> b
$ "Dictionary.dictTrans: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConstrDecl -> String
forall a. Show a => a -> String
show ConstrDecl
d

instance DictTrans Equation where
  dictTrans :: Equation PredType -> StateT DTState Identity (Equation Type)
dictTrans (Equation p :: SpanInfo
p (FunLhs _ f :: Ident
f ts :: [Pattern PredType]
ts) rhs :: Rhs PredType
rhs) = StateT DTState Identity (Equation Type)
-> StateT DTState Identity (Equation Type)
forall a. DTM a -> DTM a
withLocalValueEnv (StateT DTState Identity (Equation Type)
 -> StateT DTState Identity (Equation Type))
-> StateT DTState Identity (Equation Type)
-> StateT DTState Identity (Equation Type)
forall a b. (a -> b) -> a -> b
$ do
    ModuleIdent
m <- DTM ModuleIdent
getModuleIdent
    [Pred]
pls <- (ValueEnv -> TypeScheme) -> Type -> DTM [Pred]
matchPredList (ModuleIdent -> Ident -> ValueEnv -> TypeScheme
varType ModuleIdent
m Ident
f) (Type -> DTM [Pred]) -> Type -> DTM [Pred]
forall a b. (a -> b) -> a -> b
$
             (Pattern PredType -> Type -> Type)
-> Type -> [Pattern PredType] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
TypeArrow (Type -> Type -> Type)
-> (Pattern PredType -> Type) -> Pattern PredType -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf) (Rhs PredType -> Type
forall a. Typeable a => a -> Type
typeOf Rhs PredType
rhs) [Pattern PredType]
ts
    [Pattern Type]
ts' <- [Pred] -> [Pattern PredType] -> DTM [Pattern Type]
addDictArgs [Pred]
pls [Pattern PredType]
ts
    (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> DTM ())
-> (ValueEnv -> ValueEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ [Pattern Type] -> ValueEnv -> ValueEnv
forall t.
(Eq t, Typeable t, ValueType t) =>
[Pattern t] -> ValueEnv -> ValueEnv
bindPatterns [Pattern Type]
ts'
    SpanInfo -> Lhs Type -> Rhs Type -> Equation Type
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p (SpanInfo -> Ident -> [Pattern Type] -> Lhs Type
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
NoSpanInfo Ident
f [Pattern Type]
ts') (Rhs Type -> Equation Type)
-> StateT DTState Identity (Rhs Type)
-> StateT DTState Identity (Equation Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rhs PredType -> StateT DTState Identity (Rhs Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Rhs PredType
rhs
  dictTrans eq :: Equation PredType
eq                             =
    String -> StateT DTState Identity (Equation Type)
forall a. String -> a
internalError (String -> StateT DTState Identity (Equation Type))
-> String -> StateT DTState Identity (Equation Type)
forall a b. (a -> b) -> a -> b
$ "Dictionary.dictTrans: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Equation PredType -> String
forall a. Show a => a -> String
show Equation PredType
eq

instance DictTrans Rhs where
  dictTrans :: Rhs PredType -> StateT DTState Identity (Rhs Type)
dictTrans (SimpleRhs p :: SpanInfo
p e :: Expression PredType
e []) = SpanInfo -> Expression Type -> Rhs Type
forall a. SpanInfo -> Expression a -> Rhs a
simpleRhs SpanInfo
p (Expression Type -> Rhs Type)
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Rhs Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Expression PredType
e
  dictTrans rhs :: Rhs PredType
rhs                =
    String -> StateT DTState Identity (Rhs Type)
forall a. String -> a
internalError (String -> StateT DTState Identity (Rhs Type))
-> String -> StateT DTState Identity (Rhs Type)
forall a b. (a -> b) -> a -> b
$ "Dictionary.dictTrans: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rhs PredType -> String
forall a. Show a => a -> String
show Rhs PredType
rhs

instance DictTrans Pattern where
  dictTrans :: Pattern PredType -> StateT DTState Identity (Pattern Type)
dictTrans (LiteralPattern        _ pty :: PredType
pty l :: Literal
l) =
    Pattern Type -> StateT DTState Identity (Pattern Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern Type -> StateT DTState Identity (Pattern Type))
-> Pattern Type -> StateT DTState Identity (Pattern Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Type -> Literal -> Pattern Type
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
NoSpanInfo (PredType -> Type
unpredType PredType
pty) Literal
l
  dictTrans (VariablePattern       _ pty :: PredType
pty v :: Ident
v) =
    Pattern Type -> StateT DTState Identity (Pattern Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern Type -> StateT DTState Identity (Pattern Type))
-> Pattern Type -> StateT DTState Identity (Pattern Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Type -> Ident -> Pattern Type
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo (PredType -> Type
unpredType PredType
pty) Ident
v
  dictTrans (ConstructorPattern _ pty :: PredType
pty c :: QualIdent
c ts :: [Pattern PredType]
ts) = do
    [Pred]
pls <- (ValueEnv -> TypeScheme) -> Type -> DTM [Pred]
matchPredList (QualIdent -> ValueEnv -> TypeScheme
conType QualIdent
c) (Type -> DTM [Pred]) -> Type -> DTM [Pred]
forall a b. (a -> b) -> a -> b
$
             (Pattern PredType -> Type -> Type)
-> Type -> [Pattern PredType] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
TypeArrow (Type -> Type -> Type)
-> (Pattern PredType -> Type) -> Pattern PredType -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf) (PredType -> Type
unpredType PredType
pty) [Pattern PredType]
ts
    SpanInfo -> Type -> QualIdent -> [Pattern Type] -> Pattern Type
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo (PredType -> Type
unpredType PredType
pty) QualIdent
c ([Pattern Type] -> Pattern Type)
-> DTM [Pattern Type] -> StateT DTState Identity (Pattern Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pred] -> [Pattern PredType] -> DTM [Pattern Type]
addDictArgs [Pred]
pls [Pattern PredType]
ts
  dictTrans (AsPattern               _ v :: Ident
v t :: Pattern PredType
t) =
    SpanInfo -> Ident -> Pattern Type -> Pattern Type
forall a. SpanInfo -> Ident -> Pattern a -> Pattern a
AsPattern SpanInfo
NoSpanInfo Ident
v (Pattern Type -> Pattern Type)
-> StateT DTState Identity (Pattern Type)
-> StateT DTState Identity (Pattern Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern PredType -> StateT DTState Identity (Pattern Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Pattern PredType
t
  dictTrans t :: Pattern PredType
t                               =
    String -> StateT DTState Identity (Pattern Type)
forall a. String -> a
internalError (String -> StateT DTState Identity (Pattern Type))
-> String -> StateT DTState Identity (Pattern Type)
forall a b. (a -> b) -> a -> b
$ "Dictionary.dictTrans: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern PredType -> String
forall a. Show a => a -> String
show Pattern PredType
t

instance DictTrans Expression where
  dictTrans :: Expression PredType -> StateT DTState Identity (Expression Type)
dictTrans (Literal     _ pty :: PredType
pty l :: Literal
l) =
    Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type -> StateT DTState Identity (Expression Type))
-> Expression Type -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Type -> Literal -> Expression Type
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo (PredType -> Type
unpredType PredType
pty) Literal
l
  dictTrans (Variable    _ pty :: PredType
pty v :: QualIdent
v) = do
    [Pred]
pls <- (ValueEnv -> TypeScheme) -> Type -> DTM [Pred]
matchPredList (QualIdent -> ValueEnv -> TypeScheme
funType QualIdent
v) (PredType -> Type
unpredType PredType
pty)
    [Expression Type]
es <- (Pred -> StateT DTState Identity (Expression Type))
-> [Pred] -> StateT DTState Identity [Expression Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pred -> StateT DTState Identity (Expression Type)
dictArg [Pred]
pls
    let ty :: Type
ty = (Expression Type -> Type -> Type)
-> Type -> [Expression Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
TypeArrow (Type -> Type -> Type)
-> (Expression Type -> Type) -> Expression Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression Type -> Type
forall a. Typeable a => a -> Type
typeOf) (PredType -> Type
unpredType PredType
pty) [Expression Type]
es
    Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type -> StateT DTState Identity (Expression Type))
-> Expression Type -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> Type -> QualIdent -> Expression Type
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo Type
ty QualIdent
v) [Expression Type]
es
  dictTrans (Constructor _ pty :: PredType
pty c :: QualIdent
c) = do
    [Pred]
pls <- (ValueEnv -> TypeScheme) -> Type -> DTM [Pred]
matchPredList (QualIdent -> ValueEnv -> TypeScheme
conType QualIdent
c) (PredType -> Type
unpredType PredType
pty)
    [Expression Type]
es <- (Pred -> StateT DTState Identity (Expression Type))
-> [Pred] -> StateT DTState Identity [Expression Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pred -> StateT DTState Identity (Expression Type)
dictArg [Pred]
pls
    let ty :: Type
ty = (Expression Type -> Type -> Type)
-> Type -> [Expression Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
TypeArrow (Type -> Type -> Type)
-> (Expression Type -> Type) -> Expression Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression Type -> Type
forall a. Typeable a => a -> Type
typeOf) (PredType -> Type
unpredType PredType
pty) [Expression Type]
es
    Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type -> StateT DTState Identity (Expression Type))
-> Expression Type -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> Type -> QualIdent -> Expression Type
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo Type
ty QualIdent
c) [Expression Type]
es
  dictTrans (Apply       _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2) =
    SpanInfo -> Expression Type -> Expression Type -> Expression Type
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (Expression Type -> Expression Type -> Expression Type)
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Expression Type -> Expression Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Expression PredType
e1 StateT DTState Identity (Expression Type -> Expression Type)
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Expression Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression PredType -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Expression PredType
e2
  dictTrans (Typed       _ e :: Expression PredType
e qty :: QualTypeExpr
qty) =
    SpanInfo -> Expression Type -> QualTypeExpr -> Expression Type
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
NoSpanInfo (Expression Type -> QualTypeExpr -> Expression Type)
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity (QualTypeExpr -> Expression Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Expression PredType
e StateT DTState Identity (QualTypeExpr -> Expression Type)
-> StateT DTState Identity QualTypeExpr
-> StateT DTState Identity (Expression Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QualTypeExpr -> StateT DTState Identity QualTypeExpr
dictTransQualTypeExpr QualTypeExpr
qty
  dictTrans (Lambda       _ ts :: [Pattern PredType]
ts e :: Expression PredType
e) = StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Expression Type)
forall a. DTM a -> DTM a
withLocalValueEnv (StateT DTState Identity (Expression Type)
 -> StateT DTState Identity (Expression Type))
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Expression Type)
forall a. DTM a -> DTM a
withLocalDictEnv (StateT DTState Identity (Expression Type)
 -> StateT DTState Identity (Expression Type))
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ do
    [Pattern Type]
ts' <- (Pattern PredType -> StateT DTState Identity (Pattern Type))
-> [Pattern PredType] -> DTM [Pattern Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern PredType -> StateT DTState Identity (Pattern Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans [Pattern PredType]
ts
    (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> DTM ())
-> (ValueEnv -> ValueEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ [Pattern Type] -> ValueEnv -> ValueEnv
forall t.
(Eq t, Typeable t, ValueType t) =>
[Pattern t] -> ValueEnv -> ValueEnv
bindPatterns [Pattern Type]
ts'
    SpanInfo -> [Pattern Type] -> Expression Type -> Expression Type
forall a. SpanInfo -> [Pattern a] -> Expression a -> Expression a
Lambda SpanInfo
NoSpanInfo [Pattern Type]
ts' (Expression Type -> Expression Type)
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Expression Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Expression PredType
e
  dictTrans (Let          _ ds :: [Decl PredType]
ds e :: Expression PredType
e) = StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Expression Type)
forall a. DTM a -> DTM a
withLocalValueEnv (StateT DTState Identity (Expression Type)
 -> StateT DTState Identity (Expression Type))
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ do
    (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> DTM ())
-> (ValueEnv -> ValueEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ [Decl PredType] -> ValueEnv -> ValueEnv
forall t.
(Eq t, Typeable t, ValueType t) =>
[Decl t] -> ValueEnv -> ValueEnv
bindDecls [Decl PredType]
ds
    SpanInfo -> [Decl Type] -> Expression Type -> Expression Type
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
NoSpanInfo ([Decl Type] -> Expression Type -> Expression Type)
-> DTM [Decl Type]
-> StateT DTState Identity (Expression Type -> Expression Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl PredType -> StateT DTState Identity (Decl Type))
-> [Decl PredType] -> DTM [Decl Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl PredType -> StateT DTState Identity (Decl Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans [Decl PredType]
ds StateT DTState Identity (Expression Type -> Expression Type)
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Expression Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression PredType -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Expression PredType
e
  dictTrans (Case      _ ct :: CaseType
ct e :: Expression PredType
e as :: [Alt PredType]
as) =
    SpanInfo
-> CaseType -> Expression Type -> [Alt Type] -> Expression Type
forall a.
SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
Case SpanInfo
NoSpanInfo CaseType
ct (Expression Type -> [Alt Type] -> Expression Type)
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity ([Alt Type] -> Expression Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Expression PredType
e StateT DTState Identity ([Alt Type] -> Expression Type)
-> StateT DTState Identity [Alt Type]
-> StateT DTState Identity (Expression Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt PredType -> StateT DTState Identity (Alt Type))
-> [Alt PredType] -> StateT DTState Identity [Alt Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt PredType -> StateT DTState Identity (Alt Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans [Alt PredType]
as
  dictTrans e :: Expression PredType
e                   =
    String -> StateT DTState Identity (Expression Type)
forall a. String -> a
internalError (String -> StateT DTState Identity (Expression Type))
-> String -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ "Dictionary.dictTrans: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression PredType -> String
forall a. Show a => a -> String
show Expression PredType
e

-- Just like before in desugaring, we ignore the context in the type signature
-- of a typed expression, since there should be no possibility to provide an
-- non-empty context without scoped type-variables.
-- TODO: Verify

dictTransQualTypeExpr :: QualTypeExpr -> DTM QualTypeExpr
dictTransQualTypeExpr :: QualTypeExpr -> StateT DTState Identity QualTypeExpr
dictTransQualTypeExpr (QualTypeExpr spi :: SpanInfo
spi _ ty :: InstanceType
ty) = QualTypeExpr -> StateT DTState Identity QualTypeExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (QualTypeExpr -> StateT DTState Identity QualTypeExpr)
-> QualTypeExpr -> StateT DTState Identity QualTypeExpr
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Context -> InstanceType -> QualTypeExpr
QualTypeExpr SpanInfo
spi [] InstanceType
ty

instance DictTrans Alt where
  dictTrans :: Alt PredType -> StateT DTState Identity (Alt Type)
dictTrans (Alt p :: SpanInfo
p t :: Pattern PredType
t rhs :: Rhs PredType
rhs) = StateT DTState Identity (Alt Type)
-> StateT DTState Identity (Alt Type)
forall a. DTM a -> DTM a
withLocalValueEnv (StateT DTState Identity (Alt Type)
 -> StateT DTState Identity (Alt Type))
-> StateT DTState Identity (Alt Type)
-> StateT DTState Identity (Alt Type)
forall a b. (a -> b) -> a -> b
$ StateT DTState Identity (Alt Type)
-> StateT DTState Identity (Alt Type)
forall a. DTM a -> DTM a
withLocalDictEnv (StateT DTState Identity (Alt Type)
 -> StateT DTState Identity (Alt Type))
-> StateT DTState Identity (Alt Type)
-> StateT DTState Identity (Alt Type)
forall a b. (a -> b) -> a -> b
$ do
    Pattern Type
t' <- Pattern PredType -> StateT DTState Identity (Pattern Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Pattern PredType
t
    (ValueEnv -> ValueEnv) -> DTM ()
modifyValueEnv ((ValueEnv -> ValueEnv) -> DTM ())
-> (ValueEnv -> ValueEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ Pattern Type -> ValueEnv -> ValueEnv
forall t.
(Eq t, Typeable t, ValueType t) =>
Pattern t -> ValueEnv -> ValueEnv
bindPattern Pattern Type
t'
    SpanInfo -> Pattern Type -> Rhs Type -> Alt Type
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p Pattern Type
t' (Rhs Type -> Alt Type)
-> StateT DTState Identity (Rhs Type)
-> StateT DTState Identity (Alt Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rhs PredType -> StateT DTState Identity (Rhs Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans Rhs PredType
rhs

addDictArgs :: [Pred] -> [Pattern PredType] -> DTM [Pattern Type]
addDictArgs :: [Pred] -> [Pattern PredType] -> DTM [Pattern Type]
addDictArgs pls :: [Pred]
pls ts :: [Pattern PredType]
ts = do
  [(Type, Ident)]
dictVars <- (Pred -> StateT DTState Identity (Type, Ident))
-> [Pred] -> StateT DTState Identity [(Type, Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> StateT DTState Identity (Type, Ident)
freshVar "_#dict" (Type -> StateT DTState Identity (Type, Ident))
-> (Pred -> Type) -> Pred -> StateT DTState Identity (Type, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> Type
dictType) [Pred]
pls
  ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
  (DictEnv -> DictEnv) -> DTM ()
modifyDictEnv ((DictEnv -> DictEnv) -> DTM ()) -> (DictEnv -> DictEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ DictEnv -> DictEnv -> DictEnv
forall a. [a] -> [a] -> [a]
(++) (DictEnv -> DictEnv -> DictEnv) -> DictEnv -> DictEnv -> DictEnv
forall a b. (a -> b) -> a -> b
$ ClassEnv -> DictEnv -> DictEnv
dicts ClassEnv
clsEnv (DictEnv -> DictEnv) -> DictEnv -> DictEnv
forall a b. (a -> b) -> a -> b
$ [Pred] -> [Expression Type] -> DictEnv
forall a b. [a] -> [b] -> [(a, b)]
zip [Pred]
pls (((Type, Ident) -> Expression Type)
-> [(Type, Ident)] -> [Expression Type]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Ident -> Expression Type)
-> (Type, Ident) -> Expression Type
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> Expression Type
forall a. a -> Ident -> Expression a
mkVar) [(Type, Ident)]
dictVars)
  [Pattern Type] -> [Pattern Type] -> [Pattern Type]
forall a. [a] -> [a] -> [a]
(++) (((Type, Ident) -> Pattern Type)
-> [(Type, Ident)] -> [Pattern Type]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Ident -> Pattern Type) -> (Type, Ident) -> Pattern Type
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> Type -> Ident -> Pattern Type
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo )) [(Type, Ident)]
dictVars)
         ([Pattern Type] -> [Pattern Type])
-> DTM [Pattern Type] -> DTM [Pattern Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern PredType -> StateT DTState Identity (Pattern Type))
-> [Pattern PredType] -> DTM [Pattern Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern PredType -> StateT DTState Identity (Pattern Type)
forall (a :: * -> *). DictTrans a => a PredType -> DTM (a Type)
dictTrans [Pattern PredType]
ts
  where dicts :: ClassEnv -> DictEnv -> DictEnv
dicts clsEnv :: ClassEnv
clsEnv vs :: DictEnv
vs
          | DictEnv -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null DictEnv
vs = DictEnv
vs
          | Bool
otherwise = DictEnv
vs DictEnv -> DictEnv -> DictEnv
forall a. [a] -> [a] -> [a]
++ ClassEnv -> DictEnv -> DictEnv
dicts ClassEnv
clsEnv (((Pred, Expression Type) -> DictEnv) -> DictEnv -> DictEnv
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ClassEnv -> (Pred, Expression Type) -> DictEnv
superDicts ClassEnv
clsEnv) DictEnv
vs)
        superDicts :: ClassEnv -> (Pred, Expression Type) -> DictEnv
superDicts clsEnv :: ClassEnv
clsEnv (Pred cls :: QualIdent
cls ty :: Type
ty, e :: Expression Type
e) =
          (QualIdent -> (Pred, Expression Type)) -> AugmentEnv -> DictEnv
forall a b. (a -> b) -> [a] -> [b]
map (QualIdent
-> Type -> Expression Type -> QualIdent -> (Pred, Expression Type)
superDict QualIdent
cls Type
ty Expression Type
e) (QualIdent -> ClassEnv -> AugmentEnv
superClasses QualIdent
cls ClassEnv
clsEnv)
        superDict :: QualIdent
-> Type -> Expression Type -> QualIdent -> (Pred, Expression Type)
superDict cls :: QualIdent
cls ty :: Type
ty e :: Expression Type
e scls :: QualIdent
scls =
          (QualIdent -> Type -> Pred
Pred QualIdent
scls Type
ty, SpanInfo -> Expression Type -> Expression Type -> Expression Type
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (QualIdent -> QualIdent -> Type -> Expression Type
superDictExpr QualIdent
cls QualIdent
scls Type
ty) Expression Type
e)
        superDictExpr :: QualIdent -> QualIdent -> Type -> Expression Type
superDictExpr cls :: QualIdent
cls scls :: QualIdent
scls ty :: Type
ty =
          SpanInfo -> Type -> QualIdent -> Expression Type
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo (QualIdent -> QualIdent -> Type -> Type
superDictStubType QualIdent
cls QualIdent
scls Type
ty)
            (QualIdent -> QualIdent -> QualIdent
qSuperDictStubId QualIdent
cls QualIdent
scls)

-- The function 'dictArg' constructs the dictionary argument for a predicate
-- from the predicates of a class method or an overloaded function. It checks
-- whether a dictionary for the predicate is available in the dictionary
-- environment, which is the case when the predicate's type is a type variable,
-- and uses 'instDict' otherwise in order to supply a new dictionary using the
-- appropriate instance dictionary construction function. If the corresponding
-- instance declaration has a non-empty context, the dictionary construction
-- function is applied to the dictionaries computed for the context instantiated
-- at the appropriate types.

dictArg :: Pred -> DTM (Expression Type)
dictArg :: Pred -> StateT DTState Identity (Expression Type)
dictArg p :: Pred
p = StateT DTState Identity (Expression Type)
-> (Expression Type -> StateT DTState Identity (Expression Type))
-> StateT DTState Identity (Maybe (Expression Type))
-> StateT DTState Identity (Expression Type)
forall (m :: * -> *) b a.
Monad m =>
m b -> (a -> m b) -> m (Maybe a) -> m b
maybeM (Pred -> StateT DTState Identity (Expression Type)
instDict Pred
p) Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pred -> DictEnv -> Maybe (Expression Type)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Pred
p (DictEnv -> Maybe (Expression Type))
-> DTM DictEnv -> StateT DTState Identity (Maybe (Expression Type))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DTM DictEnv
getDictEnv)

instDict :: Pred -> DTM (Expression Type)
instDict :: Pred -> StateT DTState Identity (Expression Type)
instDict p :: Pred
p = Pred -> DTM (ModuleIdent, [Pred])
instPredList Pred
p DTM (ModuleIdent, [Pred])
-> ((ModuleIdent, [Pred])
    -> StateT DTState Identity (Expression Type))
-> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((ModuleIdent, [Pred])
 -> Pred -> StateT DTState Identity (Expression Type))
-> Pred
-> (ModuleIdent, [Pred])
-> StateT DTState Identity (Expression Type)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ModuleIdent
 -> [Pred] -> Pred -> StateT DTState Identity (Expression Type))
-> (ModuleIdent, [Pred])
-> Pred
-> StateT DTState Identity (Expression Type)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ModuleIdent
-> [Pred] -> Pred -> StateT DTState Identity (Expression Type)
instFunApp) Pred
p

instFunApp :: ModuleIdent -> [Pred] -> Pred -> DTM (Expression Type)
instFunApp :: ModuleIdent
-> [Pred] -> Pred -> StateT DTState Identity (Expression Type)
instFunApp m :: ModuleIdent
m pls :: [Pred]
pls p :: Pred
p@(Pred cls :: QualIdent
cls ty :: Type
ty) = Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> Type -> QualIdent -> Expression Type
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo Type
ty' QualIdent
f)
  ([Expression Type] -> Expression Type)
-> StateT DTState Identity [Expression Type]
-> StateT DTState Identity (Expression Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pred -> StateT DTState Identity (Expression Type))
-> [Pred] -> StateT DTState Identity [Expression Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pred -> StateT DTState Identity (Expression Type)
dictArg [Pred]
pls
  where f :: QualIdent
f   = ModuleIdent -> QualIdent -> Type -> QualIdent
qInstFunId ModuleIdent
m QualIdent
cls Type
ty
        ty' :: Type
ty' = (Type -> Type -> Type) -> [Type] -> Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Type -> Type -> Type
TypeArrow ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Pred -> Type) -> [Pred] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Pred -> Type
dictType ([Pred] -> [Type]) -> [Pred] -> [Type]
forall a b. (a -> b) -> a -> b
$ [Pred]
pls [Pred] -> [Pred] -> [Pred]
forall a. [a] -> [a] -> [a]
++ [Pred
p]

instPredList :: Pred -> DTM (ModuleIdent, [Pred])
instPredList :: Pred -> DTM (ModuleIdent, [Pred])
instPredList (Pred cls :: QualIdent
cls ty :: Type
ty) = case Bool -> Type -> (Type, [Type])
unapplyType Bool
True Type
ty of
  (TypeConstructor tc :: QualIdent
tc, tys :: [Type]
tys) -> do
    InstEnv
inEnv <- DTM InstEnv
getInstEnv
    case InstIdent -> InstEnv -> Maybe InstInfo
lookupInstInfo (QualIdent
cls, QualIdent
tc) InstEnv
inEnv of
      Just (m :: ModuleIdent
m, ps :: PredSet
ps, _) -> (ModuleIdent, [Pred]) -> DTM (ModuleIdent, [Pred])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleIdent
m, [Type] -> [Pred] -> [Pred]
forall a. ExpandAliasType a => [Type] -> a -> a
expandAliasType [Type]
tys ([Pred] -> [Pred]) -> [Pred] -> [Pred]
forall a b. (a -> b) -> a -> b
$ PredSet -> [Pred]
forall a. Set a -> [a]
Set.toAscList PredSet
ps)
      Nothing -> String -> DTM (ModuleIdent, [Pred])
forall a. String -> a
internalError (String -> DTM (ModuleIdent, [Pred]))
-> String -> DTM (ModuleIdent, [Pred])
forall a b. (a -> b) -> a -> b
$ "Dictionary.instPredList: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ InstIdent -> String
forall a. Show a => a -> String
show (QualIdent
cls, QualIdent
tc)
  _ -> String -> DTM (ModuleIdent, [Pred])
forall a. String -> a
internalError (String -> DTM (ModuleIdent, [Pred]))
-> String -> DTM (ModuleIdent, [Pred])
forall a b. (a -> b) -> a -> b
$ "Dictionary.instPredList: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ty

-- When adding dictionary arguments on the left hand side of an equation and
-- in applications, respectively, the compiler must unify the function's type
-- with the concrete instance at which that type is used in order to determine
-- the correct context.

-- Polymorphic methods make things a little bit more complicated. When an
-- instance dictionary constructor is applied to an instance method, the
-- suffix of the instance method type's context that corresponds to the
-- additional constraints of the type class method must be discarded and
-- no dictionaries must be added for these constraints. Unfortunately, the
-- dictionary transformation has already been applied to the component types
-- of the dictionary constructor. Therefore, the function 'matchPredList'
-- tries to find a suffix of the context whose transformation matches the
-- initial arrows of the instance type.

matchPredList :: (ValueEnv -> TypeScheme) -> Type -> DTM [Pred]
matchPredList :: (ValueEnv -> TypeScheme) -> Type -> DTM [Pred]
matchPredList tySc :: ValueEnv -> TypeScheme
tySc ty2 :: Type
ty2 = do
  ForAll _ (PredType ps :: PredSet
ps ty1 :: Type
ty1) <- ValueEnv -> TypeScheme
tySc (ValueEnv -> TypeScheme)
-> DTM ValueEnv -> StateT DTState Identity TypeScheme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DTM ValueEnv
getValueEnv
  [Pred] -> DTM [Pred]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pred] -> DTM [Pred]) -> [Pred] -> DTM [Pred]
forall a b. (a -> b) -> a -> b
$ (([Pred], [Pred]) -> [Pred] -> [Pred])
-> [Pred] -> [([Pred], [Pred])] -> [Pred]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(pls1 :: [Pred]
pls1, pls2 :: [Pred]
pls2) pls' :: [Pred]
pls' ->
                   [Pred] -> Maybe [Pred] -> [Pred]
forall a. a -> Maybe a -> a
fromMaybe [Pred]
pls' (Maybe [Pred] -> [Pred]) -> Maybe [Pred] -> [Pred]
forall a b. (a -> b) -> a -> b
$ [Pred] -> Type -> [Pred] -> Type -> Maybe [Pred]
qualMatch [Pred]
pls1 Type
ty1 [Pred]
pls2 Type
ty2)
                 (String -> [Pred]
forall a. String -> a
internalError (String -> [Pred]) -> String -> [Pred]
forall a b. (a -> b) -> a -> b
$ "Dictionary.matchPredList: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PredSet -> String
forall a. Show a => a -> String
show PredSet
ps)
                 ([Pred] -> [([Pred], [Pred])]
forall a. [a] -> [([a], [a])]
splits ([Pred] -> [([Pred], [Pred])]) -> [Pred] -> [([Pred], [Pred])]
forall a b. (a -> b) -> a -> b
$ PredSet -> [Pred]
forall a. Set a -> [a]
Set.toAscList PredSet
ps)

qualMatch :: [Pred] -> Type -> [Pred] -> Type -> Maybe [Pred]
qualMatch :: [Pred] -> Type -> [Pred] -> Type -> Maybe [Pred]
qualMatch pls1 :: [Pred]
pls1 ty1 :: Type
ty1 pls2 :: [Pred]
pls2 ty2 :: Type
ty2 = case [Pred] -> Type -> Maybe Type
predListMatch [Pred]
pls2 Type
ty2 of
  Just ty2' :: Type
ty2' -> [Pred] -> Maybe [Pred]
forall a. a -> Maybe a
Just ([Pred] -> Maybe [Pred]) -> [Pred] -> Maybe [Pred]
forall a b. (a -> b) -> a -> b
$ TypeSubst -> [Pred] -> [Pred]
forall a. SubstType a => TypeSubst -> a -> a
subst (Type -> Type -> TypeSubst -> TypeSubst
matchType Type
ty1 Type
ty2' TypeSubst
forall a b. Subst a b
idSubst) [Pred]
pls1
  Nothing -> Maybe [Pred]
forall a. Maybe a
Nothing

predListMatch :: [Pred] -> Type -> Maybe Type
predListMatch :: [Pred] -> Type -> Maybe Type
predListMatch []     ty :: Type
ty = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
ty
predListMatch (p :: Pred
p:ps :: [Pred]
ps) ty :: Type
ty = case Type
ty of
  TypeForall _ ty' :: Type
ty'                                 -> [Pred] -> Type -> Maybe Type
predListMatch (Pred
p Pred -> [Pred] -> [Pred]
forall a. a -> [a] -> [a]
: [Pred]
ps) Type
ty'
  TypeArrow ty1 :: Type
ty1 ty2 :: Type
ty2 | Type
ty1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Pred -> Type
dictType (Pred -> Pred
instPred Pred
p) -> [Pred] -> Type -> Maybe Type
predListMatch [Pred]
ps Type
ty2
  _                                                -> Maybe Type
forall a. Maybe a
Nothing

splits :: [a] -> [([a], [a])]
splits :: [a] -> [([a], [a])]
splits xs :: [a]
xs = [[a]] -> [[a]] -> [([a], [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [[a]]
forall a. [a] -> [[a]]
inits [a]
xs) ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs)

-- -----------------------------------------------------------------------------
-- Optimizing method calls
-- -----------------------------------------------------------------------------

-- Whenever a type class method is applied at a known type, the compiler can
-- apply the type instance's implementation directly.

type SpecEnv = Map.Map (QualIdent, QualIdent) QualIdent

emptySpEnv :: SpecEnv
emptySpEnv :: SpecEnv
emptySpEnv = SpecEnv
forall k a. Map k a
Map.empty

initSpEnv :: ClassEnv -> InstEnv -> SpecEnv
initSpEnv :: ClassEnv -> InstEnv -> SpecEnv
initSpEnv clsEnv :: ClassEnv
clsEnv = ((InstIdent, InstInfo) -> SpecEnv -> SpecEnv)
-> SpecEnv -> [(InstIdent, InstInfo)] -> SpecEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((InstIdent -> InstInfo -> SpecEnv -> SpecEnv)
-> (InstIdent, InstInfo) -> SpecEnv -> SpecEnv
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry InstIdent -> InstInfo -> SpecEnv -> SpecEnv
forall b c. InstIdent -> (ModuleIdent, b, c) -> SpecEnv -> SpecEnv
bindInstance) SpecEnv
emptySpEnv ([(InstIdent, InstInfo)] -> SpecEnv)
-> (InstEnv -> [(InstIdent, InstInfo)]) -> InstEnv -> SpecEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstEnv -> [(InstIdent, InstInfo)]
forall k a. Map k a -> [(k, a)]
Map.toList
  where bindInstance :: InstIdent -> (ModuleIdent, b, c) -> SpecEnv -> SpecEnv
bindInstance (cls :: QualIdent
cls, tc :: QualIdent
tc) (m :: ModuleIdent
m, _, _) =
          (SpecEnv -> [Ident] -> SpecEnv) -> [Ident] -> SpecEnv -> SpecEnv
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ident -> SpecEnv -> SpecEnv) -> SpecEnv -> [Ident] -> SpecEnv
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Ident -> SpecEnv -> SpecEnv) -> SpecEnv -> [Ident] -> SpecEnv)
-> (Ident -> SpecEnv -> SpecEnv) -> SpecEnv -> [Ident] -> SpecEnv
forall a b. (a -> b) -> a -> b
$ ModuleIdent
-> QualIdent -> QualIdent -> Ident -> SpecEnv -> SpecEnv
bindInstanceMethod ModuleIdent
m QualIdent
cls QualIdent
tc) ([Ident] -> SpecEnv -> SpecEnv) -> [Ident] -> SpecEnv -> SpecEnv
forall a b. (a -> b) -> a -> b
$ QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
cls ClassEnv
clsEnv
        bindInstanceMethod :: ModuleIdent
-> QualIdent -> QualIdent -> Ident -> SpecEnv -> SpecEnv
bindInstanceMethod m :: ModuleIdent
m cls :: QualIdent
cls tc :: QualIdent
tc f :: Ident
f = InstIdent -> QualIdent -> SpecEnv -> SpecEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (QualIdent
f', QualIdent
d) QualIdent
f''
          where f' :: QualIdent
f'  = QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
cls Ident
f
                d :: QualIdent
d   = ModuleIdent -> QualIdent -> Type -> QualIdent
qInstFunId ModuleIdent
m QualIdent
cls Type
ty
                f'' :: QualIdent
f'' = ModuleIdent -> QualIdent -> Type -> Ident -> QualIdent
qImplMethodId ModuleIdent
m QualIdent
cls Type
ty Ident
f
                ty :: Type
ty  = QualIdent -> Type
TypeConstructor QualIdent
tc

class Specialize a where
  specialize :: a Type -> DTM (a Type)

instance Specialize Module where
  specialize :: Module Type -> DTM (Module Type)
specialize (Module spi :: SpanInfo
spi ps :: [ModulePragma]
ps m :: ModuleIdent
m es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl Type]
ds) = do
    ClassEnv
clsEnv <- DTM ClassEnv
getClassEnv
    InstEnv
inEnv <- DTM InstEnv
getInstEnv
    SpecEnv -> DTM ()
setSpEnv (SpecEnv -> DTM ()) -> SpecEnv -> DTM ()
forall a b. (a -> b) -> a -> b
$ ClassEnv -> InstEnv -> SpecEnv
initSpEnv ClassEnv
clsEnv InstEnv
inEnv
    SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl Type]
-> Module Type
forall a.
SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
Module SpanInfo
spi [ModulePragma]
ps ModuleIdent
m Maybe ExportSpec
es [ImportDecl]
is ([Decl Type] -> Module Type)
-> DTM [Decl Type] -> DTM (Module Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl Type -> StateT DTState Identity (Decl Type))
-> [Decl Type] -> DTM [Decl Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl Type -> StateT DTState Identity (Decl Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize [Decl Type]
ds

instance Specialize Decl where
  specialize :: Decl Type -> StateT DTState Identity (Decl Type)
specialize (FunctionDecl p :: SpanInfo
p ty :: Type
ty f :: Ident
f eqs :: [Equation Type]
eqs) =
    SpanInfo -> Type -> Ident -> [Equation Type] -> Decl Type
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p Type
ty Ident
f ([Equation Type] -> Decl Type)
-> StateT DTState Identity [Equation Type]
-> StateT DTState Identity (Decl Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Equation Type -> StateT DTState Identity (Equation Type))
-> [Equation Type] -> StateT DTState Identity [Equation Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Equation Type -> StateT DTState Identity (Equation Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize [Equation Type]
eqs
  specialize (PatternDecl     p :: SpanInfo
p t :: Pattern Type
t rhs :: Rhs Type
rhs) = SpanInfo -> Pattern Type -> Rhs Type -> Decl Type
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern Type
t (Rhs Type -> Decl Type)
-> StateT DTState Identity (Rhs Type)
-> StateT DTState Identity (Decl Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rhs Type -> StateT DTState Identity (Rhs Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize Rhs Type
rhs
  specialize d :: Decl Type
d                         = Decl Type -> StateT DTState Identity (Decl Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl Type
d

instance Specialize Equation where
  specialize :: Equation Type -> StateT DTState Identity (Equation Type)
specialize (Equation p :: SpanInfo
p lhs :: Lhs Type
lhs rhs :: Rhs Type
rhs) = SpanInfo -> Lhs Type -> Rhs Type -> Equation Type
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p Lhs Type
lhs (Rhs Type -> Equation Type)
-> StateT DTState Identity (Rhs Type)
-> StateT DTState Identity (Equation Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rhs Type -> StateT DTState Identity (Rhs Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize Rhs Type
rhs

instance Specialize Rhs where
  specialize :: Rhs Type -> StateT DTState Identity (Rhs Type)
specialize (SimpleRhs p :: SpanInfo
p e :: Expression Type
e []) = SpanInfo -> Expression Type -> Rhs Type
forall a. SpanInfo -> Expression a -> Rhs a
simpleRhs SpanInfo
p (Expression Type -> Rhs Type)
-> StateT DTState Identity (Expression Type)
-> StateT DTState Identity (Rhs Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression Type -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize Expression Type
e
  specialize rhs :: Rhs Type
rhs                =
    String -> StateT DTState Identity (Rhs Type)
forall a. String -> a
internalError (String -> StateT DTState Identity (Rhs Type))
-> String -> StateT DTState Identity (Rhs Type)
forall a b. (a -> b) -> a -> b
$ "Dictionary.specialize: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Rhs Type -> String
forall a. Show a => a -> String
show Rhs Type
rhs

instance Specialize Expression where
  specialize :: Expression Type -> StateT DTState Identity (Expression Type)
specialize e :: Expression Type
e = Expression Type
-> [Expression Type] -> StateT DTState Identity (Expression Type)
specialize' Expression Type
e []

specialize' :: Expression Type -> [Expression Type] -> DTM (Expression Type)
specialize' :: Expression Type
-> [Expression Type] -> StateT DTState Identity (Expression Type)
specialize' l :: Expression Type
l@(Literal     _ _ _) es :: [Expression Type]
es = Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type -> StateT DTState Identity (Expression Type))
-> Expression Type -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply Expression Type
l [Expression Type]
es
specialize' v :: Expression Type
v@(Variable   _ _ v' :: QualIdent
v') es :: [Expression Type]
es = do
  SpecEnv
spEnv <- DTM SpecEnv
getSpEnv
  Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type -> StateT DTState Identity (Expression Type))
-> Expression Type -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ case InstIdent -> SpecEnv -> Maybe QualIdent
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (QualIdent
v', QualIdent
f) SpecEnv
spEnv of
    Just f' :: QualIdent
f' -> Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> Type -> QualIdent -> Expression Type
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo Type
ty' QualIdent
f') ([Expression Type] -> Expression Type)
-> [Expression Type] -> Expression Type
forall a b. (a -> b) -> a -> b
$ [Expression Type]
es'' [Expression Type] -> [Expression Type] -> [Expression Type]
forall a. [a] -> [a] -> [a]
++ [Expression Type]
es'
    Nothing -> Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply Expression Type
v [Expression Type]
es
  where d :: Expression Type
d:es' :: [Expression Type]
es' = [Expression Type]
es
        (Variable _ _ f :: QualIdent
f, es'' :: [Expression Type]
es'') = Expression Type
-> [Expression Type] -> (Expression Type, [Expression Type])
forall a.
Expression a -> [Expression a] -> (Expression a, [Expression a])
unapply Expression Type
d []
        ty' :: Type
ty' = (Expression Type -> Type -> Type)
-> Type -> [Expression Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
TypeArrow (Type -> Type -> Type)
-> (Expression Type -> Type) -> Expression Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression Type -> Type
forall a. Typeable a => a -> Type
typeOf) (Expression Type -> Type
forall a. Typeable a => a -> Type
typeOf (Expression Type -> Type) -> Expression Type -> Type
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Expression Type -> Expression Type -> Expression Type
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo Expression Type
v Expression Type
d) [Expression Type]
es''
specialize' c :: Expression Type
c@(Constructor _ _ _) es :: [Expression Type]
es = Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type -> StateT DTState Identity (Expression Type))
-> Expression Type -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply Expression Type
c [Expression Type]
es
specialize' (Typed       _ e :: Expression Type
e qty :: QualTypeExpr
qty) es :: [Expression Type]
es = do
  Expression Type
e' <- Expression Type -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize Expression Type
e
  Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type -> StateT DTState Identity (Expression Type))
-> Expression Type -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> Expression Type -> QualTypeExpr -> Expression Type
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
NoSpanInfo Expression Type
e' QualTypeExpr
qty) [Expression Type]
es
specialize' (Apply       _ e1 :: Expression Type
e1 e2 :: Expression Type
e2) es :: [Expression Type]
es = do
  Expression Type
e2' <- Expression Type -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize Expression Type
e2
  Expression Type
-> [Expression Type] -> StateT DTState Identity (Expression Type)
specialize' Expression Type
e1 ([Expression Type] -> StateT DTState Identity (Expression Type))
-> [Expression Type] -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ Expression Type
e2' Expression Type -> [Expression Type] -> [Expression Type]
forall a. a -> [a] -> [a]
: [Expression Type]
es
specialize' (Lambda       _ ts :: [Pattern Type]
ts e :: Expression Type
e) es :: [Expression Type]
es = do
  Expression Type
e' <- Expression Type -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize Expression Type
e
  Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type -> StateT DTState Identity (Expression Type))
-> Expression Type -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> [Pattern Type] -> Expression Type -> Expression Type
forall a. SpanInfo -> [Pattern a] -> Expression a -> Expression a
Lambda SpanInfo
NoSpanInfo [Pattern Type]
ts Expression Type
e') [Expression Type]
es
specialize' (Let          _ ds :: [Decl Type]
ds e :: Expression Type
e) es :: [Expression Type]
es = do
  [Decl Type]
ds' <- (Decl Type -> StateT DTState Identity (Decl Type))
-> [Decl Type] -> DTM [Decl Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl Type -> StateT DTState Identity (Decl Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize [Decl Type]
ds
  Expression Type
e' <- Expression Type -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize Expression Type
e
  Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type -> StateT DTState Identity (Expression Type))
-> Expression Type -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> [Decl Type] -> Expression Type -> Expression Type
forall a. SpanInfo -> [Decl a] -> Expression a -> Expression a
Let SpanInfo
NoSpanInfo [Decl Type]
ds' Expression Type
e') [Expression Type]
es
specialize' (Case      _ ct :: CaseType
ct e :: Expression Type
e as :: [Alt Type]
as) es :: [Expression Type]
es = do
  Expression Type
e' <- Expression Type -> StateT DTState Identity (Expression Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize Expression Type
e
  [Alt Type]
as' <- (Alt Type -> StateT DTState Identity (Alt Type))
-> [Alt Type] -> StateT DTState Identity [Alt Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt Type -> StateT DTState Identity (Alt Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize [Alt Type]
as
  Expression Type -> StateT DTState Identity (Expression Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression Type -> StateT DTState Identity (Expression Type))
-> Expression Type -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ Expression Type -> [Expression Type] -> Expression Type
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo
-> CaseType -> Expression Type -> [Alt Type] -> Expression Type
forall a.
SpanInfo -> CaseType -> Expression a -> [Alt a] -> Expression a
Case SpanInfo
NoSpanInfo CaseType
ct Expression Type
e' [Alt Type]
as') [Expression Type]
es
specialize' e :: Expression Type
e                   _  =
  String -> StateT DTState Identity (Expression Type)
forall a. String -> a
internalError (String -> StateT DTState Identity (Expression Type))
-> String -> StateT DTState Identity (Expression Type)
forall a b. (a -> b) -> a -> b
$ "Dictionary.specialize': " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Expression Type -> String
forall a. Show a => a -> String
show Expression Type
e

instance Specialize Alt where
  specialize :: Alt Type -> StateT DTState Identity (Alt Type)
specialize (Alt p :: SpanInfo
p t :: Pattern Type
t rhs :: Rhs Type
rhs) = SpanInfo -> Pattern Type -> Rhs Type -> Alt Type
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p Pattern Type
t (Rhs Type -> Alt Type)
-> StateT DTState Identity (Rhs Type)
-> StateT DTState Identity (Alt Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rhs Type -> StateT DTState Identity (Rhs Type)
forall (a :: * -> *). Specialize a => a Type -> DTM (a Type)
specialize Rhs Type
rhs

-- -----------------------------------------------------------------------------
-- Cleaning up
-- -----------------------------------------------------------------------------

-- After we have transformed the module we have to remove class exports from
-- the export list and type classes from the type constructor environment.
-- Furthermore, we may have to remove some infix declarations and operators
-- from the precedence environment as functions with class constraint have
-- been supplemented with addiontal dictionary arguments during the dictionary
-- transformation.

cleanup :: Module a -> DTM (Module a)
cleanup :: Module a -> DTM (Module a)
cleanup (Module spi :: SpanInfo
spi ps :: [ModulePragma]
ps m :: ModuleIdent
m es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl a]
ds) = do
  Maybe ExportSpec
cleanedEs <- (ExportSpec -> StateT DTState Identity ExportSpec)
-> Maybe ExportSpec -> StateT DTState Identity (Maybe ExportSpec)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ExportSpec -> StateT DTState Identity ExportSpec
cleanupExportSpec Maybe ExportSpec
es
  [Decl a]
cleanedDs <- (Decl a -> StateT DTState Identity [Decl a])
-> [Decl a] -> StateT DTState Identity [Decl a]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl a -> StateT DTState Identity [Decl a]
forall a. Decl a -> DTM [Decl a]
cleanupInfixDecl [Decl a]
ds
  DTM ()
cleanupTyConsEnv
  DTM ()
cleanupPrecEnv
  Module a -> DTM (Module a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Module a -> DTM (Module a)) -> Module a -> DTM (Module a)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
forall a.
SpanInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
Module SpanInfo
spi [ModulePragma]
ps ModuleIdent
m Maybe ExportSpec
cleanedEs [ImportDecl]
is [Decl a]
cleanedDs

cleanupExportSpec :: ExportSpec -> DTM ExportSpec
cleanupExportSpec :: ExportSpec -> StateT DTState Identity ExportSpec
cleanupExportSpec (Exporting p :: SpanInfo
p es :: [Export]
es) = SpanInfo -> [Export] -> ExportSpec
Exporting SpanInfo
p ([Export] -> ExportSpec)
-> DTM [Export] -> StateT DTState Identity ExportSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Export -> DTM [Export]) -> [Export] -> DTM [Export]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Export -> DTM [Export]
cleanupExport [Export]
es

cleanupExport :: Export -> DTM [Export]
cleanupExport :: Export -> DTM [Export]
cleanupExport e :: Export
e@(Export             _ _) = [Export] -> DTM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return [Export
e]
cleanupExport e :: Export
e@(ExportTypeWith spi :: SpanInfo
spi tc :: QualIdent
tc cs :: [Ident]
cs) = do
  TCEnv
tcEnv <- DTM TCEnv
getTyConsEnv
  case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
tc TCEnv
tcEnv of
    [TypeClass _ _ _] -> [Export] -> DTM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Export] -> DTM [Export]) -> [Export] -> DTM [Export]
forall a b. (a -> b) -> a -> b
$ (Ident -> Export) -> [Ident] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (SpanInfo -> QualIdent -> Export
Export SpanInfo
spi (QualIdent -> Export) -> (Ident -> QualIdent) -> Ident -> Export
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
tc) [Ident]
cs
    _                 -> [Export] -> DTM [Export]
forall (m :: * -> *) a. Monad m => a -> m a
return [Export
e]
cleanupExport e :: Export
e                        =
  String -> DTM [Export]
forall a. String -> a
internalError (String -> DTM [Export]) -> String -> DTM [Export]
forall a b. (a -> b) -> a -> b
$ "Dictionary.cleanupExport: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Export -> String
forall a. Show a => a -> String
show Export
e

cleanupInfixDecl :: Decl a -> DTM [Decl a]
cleanupInfixDecl :: Decl a -> DTM [Decl a]
cleanupInfixDecl (InfixDecl p :: SpanInfo
p fix :: Infix
fix pr :: Maybe Integer
pr ops :: [Ident]
ops) = do
  ModuleIdent
m <- DTM ModuleIdent
getModuleIdent
  ValueEnv
vEnv <- DTM ValueEnv
getValueEnv
  let opArity :: Ident -> Int
opArity = Type -> Int
arrowArity (Type -> Int) -> (Ident -> Type) -> Ident -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeScheme -> Type
rawType (TypeScheme -> Type) -> (Ident -> TypeScheme) -> Ident -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualIdent -> ValueEnv -> TypeScheme)
-> ValueEnv -> QualIdent -> TypeScheme
forall a b c. (a -> b -> c) -> b -> a -> c
flip QualIdent -> ValueEnv -> TypeScheme
opType ValueEnv
vEnv (QualIdent -> TypeScheme)
-> (Ident -> QualIdent) -> Ident -> TypeScheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m
      ops' :: [Ident]
ops' = (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2) (Int -> Bool) -> (Ident -> Int) -> Ident -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Int
opArity) [Ident]
ops
  [Decl a] -> DTM [Decl a]
forall (m :: * -> *) a. Monad m => a -> m a
return [SpanInfo -> Infix -> Maybe Integer -> [Ident] -> Decl a
forall a. SpanInfo -> Infix -> Maybe Integer -> [Ident] -> Decl a
InfixDecl SpanInfo
p Infix
fix Maybe Integer
pr [Ident]
ops' | Bool -> Bool
not ([Ident] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
ops')]
cleanupInfixDecl d :: Decl a
d                        = [Decl a] -> DTM [Decl a]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl a
d]

cleanupTyConsEnv :: DTM ()
cleanupTyConsEnv :: DTM ()
cleanupTyConsEnv = DTM TCEnv
getTyConsEnv DTM TCEnv -> (TCEnv -> DTM ()) -> DTM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((QualIdent, TypeInfo) -> DTM ())
-> [(QualIdent, TypeInfo)] -> DTM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (QualIdent -> DTM ()
cleanupTyCons (QualIdent -> DTM ())
-> ((QualIdent, TypeInfo) -> QualIdent)
-> (QualIdent, TypeInfo)
-> DTM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualIdent, TypeInfo) -> QualIdent
forall a b. (a, b) -> a
fst) ([(QualIdent, TypeInfo)] -> DTM ())
-> (TCEnv -> [(QualIdent, TypeInfo)]) -> TCEnv -> DTM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCEnv -> [(QualIdent, TypeInfo)]
forall a. TopEnv a -> [(QualIdent, a)]
allBindings

cleanupTyCons :: QualIdent -> DTM ()
cleanupTyCons :: QualIdent -> DTM ()
cleanupTyCons tc :: QualIdent
tc = do
  TCEnv
tcEnv <- DTM TCEnv
getTyConsEnv
  case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
tc TCEnv
tcEnv of
    [TypeClass _ _ _] -> (TCEnv -> TCEnv) -> DTM ()
modifyTyConsEnv ((TCEnv -> TCEnv) -> DTM ()) -> (TCEnv -> TCEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> TCEnv -> TCEnv
forall a. QualIdent -> TopEnv a -> TopEnv a
qualUnbindTopEnv QualIdent
tc
    _                 -> () -> DTM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

cleanupPrecEnv :: DTM ()
cleanupPrecEnv :: DTM ()
cleanupPrecEnv = DTM OpPrecEnv
getPrecEnv DTM OpPrecEnv -> (OpPrecEnv -> DTM ()) -> DTM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((QualIdent, PrecInfo) -> DTM ())
-> [(QualIdent, PrecInfo)] -> DTM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (QualIdent -> DTM ()
cleanupOp (QualIdent -> DTM ())
-> ((QualIdent, PrecInfo) -> QualIdent)
-> (QualIdent, PrecInfo)
-> DTM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualIdent, PrecInfo) -> QualIdent
forall a b. (a, b) -> a
fst) ([(QualIdent, PrecInfo)] -> DTM ())
-> (OpPrecEnv -> [(QualIdent, PrecInfo)]) -> OpPrecEnv -> DTM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OpPrecEnv -> [(QualIdent, PrecInfo)]
forall a. TopEnv a -> [(QualIdent, a)]
allBindings

cleanupOp :: QualIdent -> DTM ()
cleanupOp :: QualIdent -> DTM ()
cleanupOp op :: QualIdent
op = do
  Int
opArity <- Type -> Int
arrowArity (Type -> Int) -> (ValueEnv -> Type) -> ValueEnv -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeScheme -> Type
rawType (TypeScheme -> Type)
-> (ValueEnv -> TypeScheme) -> ValueEnv -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> ValueEnv -> TypeScheme
opType QualIdent
op (ValueEnv -> Int) -> DTM ValueEnv -> StateT DTState Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DTM ValueEnv
getValueEnv
  Bool -> DTM () -> DTM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
opArity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 2) (DTM () -> DTM ()) -> DTM () -> DTM ()
forall a b. (a -> b) -> a -> b
$ (OpPrecEnv -> OpPrecEnv) -> DTM ()
modifyPrecEnv ((OpPrecEnv -> OpPrecEnv) -> DTM ())
-> (OpPrecEnv -> OpPrecEnv) -> DTM ()
forall a b. (a -> b) -> a -> b
$ QualIdent -> OpPrecEnv -> OpPrecEnv
forall a. QualIdent -> TopEnv a -> TopEnv a
qualUnbindTopEnv QualIdent
op

-- -----------------------------------------------------------------------------
-- Transforming interfaces
-- -----------------------------------------------------------------------------

-- The following functions expect an already transformed value environment.
-- The transformation of interface declarations with it is quite simple and
-- straightforward.

dictTransInterfaces :: ValueEnv -> ClassEnv -> InterfaceEnv -> InterfaceEnv
dictTransInterfaces :: ValueEnv -> ClassEnv -> InterfaceEnv -> InterfaceEnv
dictTransInterfaces vEnv :: ValueEnv
vEnv clsEnv :: ClassEnv
clsEnv = (Interface -> Interface) -> InterfaceEnv -> InterfaceEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Interface -> Interface) -> InterfaceEnv -> InterfaceEnv)
-> (Interface -> Interface) -> InterfaceEnv -> InterfaceEnv
forall a b. (a -> b) -> a -> b
$ ValueEnv -> ClassEnv -> Interface -> Interface
dictTransInterface ValueEnv
vEnv ClassEnv
clsEnv

dictTransInterface :: ValueEnv -> ClassEnv -> Interface -> Interface
dictTransInterface :: ValueEnv -> ClassEnv -> Interface -> Interface
dictTransInterface vEnv :: ValueEnv
vEnv clsEnv :: ClassEnv
clsEnv (Interface m :: ModuleIdent
m is :: [IImportDecl]
is ds :: [IDecl]
ds) =
  ModuleIdent -> [IImportDecl] -> [IDecl] -> Interface
Interface ModuleIdent
m [IImportDecl]
is ([IDecl] -> Interface) -> [IDecl] -> Interface
forall a b. (a -> b) -> a -> b
$ (IDecl -> [IDecl]) -> [IDecl] -> [IDecl]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleIdent -> ValueEnv -> ClassEnv -> IDecl -> [IDecl]
dictTransIDecl ModuleIdent
m ValueEnv
vEnv ClassEnv
clsEnv) [IDecl]
ds

dictTransIDecl :: ModuleIdent -> ValueEnv -> ClassEnv -> IDecl -> [IDecl]
dictTransIDecl :: ModuleIdent -> ValueEnv -> ClassEnv -> IDecl -> [IDecl]
dictTransIDecl m :: ModuleIdent
m vEnv :: ValueEnv
vEnv _      d :: IDecl
d@(IInfixDecl         _ _ _ op :: QualIdent
op)
  | Type -> Int
arrowArity (TypeScheme -> Type
rawType (TypeScheme -> Type) -> TypeScheme -> Type
forall a b. (a -> b) -> a -> b
$ QualIdent -> ValueEnv -> TypeScheme
opType (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
op) ValueEnv
vEnv) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 2 = []
  | Bool
otherwise = [IDecl
d]
dictTransIDecl _ _    _      d :: IDecl
d@(HidingDataDecl      _ _ _ _) = [IDecl
d]
dictTransIDecl m :: ModuleIdent
m _    _      (IDataDecl    p :: Position
p tc :: QualIdent
tc k :: Maybe KindExpr
k tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs hs :: [Ident]
hs) =
  [Position
-> QualIdent
-> Maybe KindExpr
-> [Ident]
-> [ConstrDecl]
-> [Ident]
-> IDecl
IDataDecl Position
p QualIdent
tc Maybe KindExpr
k [Ident]
tvs ((ConstrDecl -> ConstrDecl) -> [ConstrDecl] -> [ConstrDecl]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> [Ident] -> ConstrDecl -> ConstrDecl
dictTransIConstrDecl ModuleIdent
m [Ident]
tvs) [ConstrDecl]
cs) [Ident]
hs]
dictTransIDecl _ _    _      d :: IDecl
d@(INewtypeDecl    _ _ _ _ _ _) = [IDecl
d]
dictTransIDecl _ _    _      d :: IDecl
d@(ITypeDecl         _ _ _ _ _) = [IDecl
d]
dictTransIDecl m :: ModuleIdent
m vEnv :: ValueEnv
vEnv _      (IFunctionDecl       _ f :: QualIdent
f _ _ _) =
  [ModuleIdent -> ValueEnv -> QualIdent -> IDecl
iFunctionDeclFromValue ModuleIdent
m ValueEnv
vEnv (ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
f)]
dictTransIDecl _ _    _      (HidingClassDecl  p :: Position
p _ cls :: QualIdent
cls k :: Maybe KindExpr
k tv :: Ident
tv) =
  [Position -> QualIdent -> Maybe KindExpr -> [Ident] -> IDecl
HidingDataDecl Position
p (QualIdent -> QualIdent
qDictTypeId QualIdent
cls) ((KindExpr -> KindExpr) -> Maybe KindExpr -> Maybe KindExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((KindExpr -> KindExpr -> KindExpr)
-> KindExpr -> KindExpr -> KindExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip KindExpr -> KindExpr -> KindExpr
ArrowKind KindExpr
Star) Maybe KindExpr
k) [Ident
tv]]
dictTransIDecl m :: ModuleIdent
m vEnv :: ValueEnv
vEnv clsEnv :: ClassEnv
clsEnv (IClassDecl   p :: Position
p _ cls :: QualIdent
cls k :: Maybe KindExpr
k _ _ hs :: [Ident]
hs) =
  IDecl
dictDecl IDecl -> [IDecl] -> [IDecl]
forall a. a -> [a] -> [a]
: [IDecl]
defaults [IDecl] -> [IDecl] -> [IDecl]
forall a. [a] -> [a] -> [a]
++ [IDecl]
methodStubs [IDecl] -> [IDecl] -> [IDecl]
forall a. [a] -> [a] -> [a]
++ [IDecl]
superDictStubs
  where qcls :: QualIdent
qcls  = ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
cls
        sclss :: AugmentEnv
sclss = QualIdent -> ClassEnv -> AugmentEnv
superClasses QualIdent
qcls ClassEnv
clsEnv
        ms :: [Ident]
ms    = QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
qcls ClassEnv
clsEnv
        dictDecl :: IDecl
dictDecl    = Position
-> QualIdent
-> Maybe KindExpr
-> [Ident]
-> [ConstrDecl]
-> [Ident]
-> IDecl
IDataDecl Position
p (QualIdent -> QualIdent
qDictTypeId QualIdent
cls)
                        ((KindExpr -> KindExpr) -> Maybe KindExpr -> Maybe KindExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((KindExpr -> KindExpr -> KindExpr)
-> KindExpr -> KindExpr -> KindExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip KindExpr -> KindExpr -> KindExpr
ArrowKind KindExpr
Star) Maybe KindExpr
k)
                        [[Ident] -> Ident
forall a. [a] -> a
head [Ident]
identSupply] [ConstrDecl
constrDecl] []
        constrDecl :: ConstrDecl
constrDecl  = ModuleIdent -> ValueEnv -> QualIdent -> ConstrDecl
iConstrDeclFromDataConstructor ModuleIdent
m ValueEnv
vEnv (QualIdent -> ConstrDecl) -> QualIdent -> ConstrDecl
forall a b. (a -> b) -> a -> b
$ QualIdent -> QualIdent
qDictConstrId QualIdent
qcls
        defaults :: [IDecl]
defaults    = (Ident -> IDecl) -> [Ident] -> [IDecl]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> ValueEnv -> QualIdent -> IDecl
iFunctionDeclFromValue ModuleIdent
m ValueEnv
vEnv (QualIdent -> IDecl) -> (Ident -> QualIdent) -> Ident -> IDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                            QualIdent -> Ident -> QualIdent
qDefaultMethodId QualIdent
qcls) [Ident]
ms
        methodStubs :: [IDecl]
methodStubs = (Ident -> IDecl) -> [Ident] -> [IDecl]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> ValueEnv -> QualIdent -> IDecl
iFunctionDeclFromValue ModuleIdent
m ValueEnv
vEnv (QualIdent -> IDecl) -> (Ident -> QualIdent) -> Ident -> IDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
qcls) ([Ident] -> [IDecl]) -> [Ident] -> [IDecl]
forall a b. (a -> b) -> a -> b
$
                        (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
filter (Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Ident]
hs) [Ident]
ms
        superDictStubs :: [IDecl]
superDictStubs = (QualIdent -> IDecl) -> AugmentEnv -> [IDecl]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> ValueEnv -> QualIdent -> IDecl
iFunctionDeclFromValue ModuleIdent
m ValueEnv
vEnv (QualIdent -> IDecl)
-> (QualIdent -> QualIdent) -> QualIdent -> IDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               QualIdent -> QualIdent -> QualIdent
qSuperDictStubId QualIdent
qcls) AugmentEnv
sclss
dictTransIDecl m :: ModuleIdent
m vEnv :: ValueEnv
vEnv clsEnv :: ClassEnv
clsEnv (IInstanceDecl _ _ cls :: QualIdent
cls ty :: InstanceType
ty _ mm :: Maybe ModuleIdent
mm) =
  ModuleIdent -> ValueEnv -> QualIdent -> IDecl
iFunctionDeclFromValue ModuleIdent
m ValueEnv
vEnv (ModuleIdent -> QualIdent -> Type -> QualIdent
qInstFunId ModuleIdent
m' QualIdent
qcls Type
ty') IDecl -> [IDecl] -> [IDecl]
forall a. a -> [a] -> [a]
:
    (Ident -> IDecl) -> [Ident] -> [IDecl]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> ValueEnv -> QualIdent -> IDecl
iFunctionDeclFromValue ModuleIdent
m ValueEnv
vEnv (QualIdent -> IDecl) -> (Ident -> QualIdent) -> Ident -> IDecl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> QualIdent -> Type -> Ident -> QualIdent
qImplMethodId ModuleIdent
m' QualIdent
qcls Type
ty') [Ident]
ms
  where m' :: ModuleIdent
m'   = ModuleIdent -> Maybe ModuleIdent -> ModuleIdent
forall a. a -> Maybe a -> a
fromMaybe ModuleIdent
m Maybe ModuleIdent
mm
        qcls :: QualIdent
qcls = ModuleIdent -> QualIdent -> QualIdent
qualQualify ModuleIdent
m QualIdent
cls
        ty' :: Type
ty'  = ModuleIdent -> [Ident] -> InstanceType -> Type
toQualType ModuleIdent
m [] InstanceType
ty
        ms :: [Ident]
ms   = QualIdent -> ClassEnv -> [Ident]
classMethods QualIdent
qcls ClassEnv
clsEnv

dictTransIConstrDecl :: ModuleIdent -> [Ident] -> ConstrDecl -> ConstrDecl
dictTransIConstrDecl :: ModuleIdent -> [Ident] -> ConstrDecl -> ConstrDecl
dictTransIConstrDecl _ _ (ConOpDecl p :: SpanInfo
p ty1 :: InstanceType
ty1 op :: Ident
op ty2 :: InstanceType
ty2) = SpanInfo -> Ident -> [InstanceType] -> ConstrDecl
ConstrDecl SpanInfo
p Ident
op [InstanceType
ty1, InstanceType
ty2]
dictTransIConstrDecl _ _ cd :: ConstrDecl
cd                       = ConstrDecl
cd

iFunctionDeclFromValue :: ModuleIdent -> ValueEnv -> QualIdent -> IDecl
iFunctionDeclFromValue :: ModuleIdent -> ValueEnv -> QualIdent -> IDecl
iFunctionDeclFromValue m :: ModuleIdent
m vEnv :: ValueEnv
vEnv f :: QualIdent
f = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
f ValueEnv
vEnv of
  [Value _ _ a :: Int
a (ForAll _ pty :: PredType
pty)] ->
    Position
-> QualIdent -> Maybe Ident -> Int -> QualTypeExpr -> IDecl
IFunctionDecl Position
NoPos (ModuleIdent -> QualIdent -> QualIdent
qualUnqualify ModuleIdent
m QualIdent
f) Maybe Ident
forall a. Maybe a
Nothing Int
a (QualTypeExpr -> IDecl) -> QualTypeExpr -> IDecl
forall a b. (a -> b) -> a -> b
$
      ModuleIdent -> [Ident] -> PredType -> QualTypeExpr
fromQualPredType ModuleIdent
m [Ident]
identSupply PredType
pty
  _ -> String -> IDecl
forall a. String -> a
internalError (String -> IDecl) -> String -> IDecl
forall a b. (a -> b) -> a -> b
$ "Dictionary.iFunctionDeclFromValue: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
f

iConstrDeclFromDataConstructor :: ModuleIdent -> ValueEnv -> QualIdent
                               -> ConstrDecl
iConstrDeclFromDataConstructor :: ModuleIdent -> ValueEnv -> QualIdent -> ConstrDecl
iConstrDeclFromDataConstructor m :: ModuleIdent
m vEnv :: ValueEnv
vEnv c :: QualIdent
c = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
c ValueEnv
vEnv of
  [DataConstructor _ _ _ (ForAll _ pty :: PredType
pty)] ->
    SpanInfo -> Ident -> [InstanceType] -> ConstrDecl
ConstrDecl SpanInfo
NoSpanInfo (QualIdent -> Ident
unqualify QualIdent
c) [InstanceType]
tys
    where tys :: [InstanceType]
tys = (Type -> InstanceType) -> [Type] -> [InstanceType]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> [Ident] -> Type -> InstanceType
fromQualType ModuleIdent
m [Ident]
identSupply) ([Type] -> [InstanceType]) -> [Type] -> [InstanceType]
forall a b. (a -> b) -> a -> b
$ Type -> [Type]
arrowArgs (Type -> [Type]) -> Type -> [Type]
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty
  _ -> String -> ConstrDecl
forall a. String -> a
internalError (String -> ConstrDecl) -> String -> ConstrDecl
forall a b. (a -> b) -> a -> b
$ "Dictionary.iConstrDeclFromDataConstructor: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
c

-- -----------------------------------------------------------------------------
-- Functions for naming newly created types, functions and parameters
-- -----------------------------------------------------------------------------

dictTypeId :: QualIdent -> Ident
dictTypeId :: QualIdent -> Ident
dictTypeId cls :: QualIdent
cls = String -> Ident
mkIdent (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ "_Dict#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
idName (QualIdent -> Ident
unqualify QualIdent
cls)

qDictTypeId :: QualIdent -> QualIdent
qDictTypeId :: QualIdent -> QualIdent
qDictTypeId cls :: QualIdent
cls = QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
cls (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ QualIdent -> Ident
dictTypeId QualIdent
cls

dictConstrId :: QualIdent -> Ident
dictConstrId :: QualIdent -> Ident
dictConstrId = QualIdent -> Ident
dictTypeId

qDictConstrId :: QualIdent -> QualIdent
qDictConstrId :: QualIdent -> QualIdent
qDictConstrId cls :: QualIdent
cls = QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
cls (Ident -> QualIdent) -> Ident -> QualIdent
forall a b. (a -> b) -> a -> b
$ QualIdent -> Ident
dictConstrId QualIdent
cls

defaultMethodId :: QualIdent -> Ident -> Ident
defaultMethodId :: QualIdent -> Ident -> Ident
defaultMethodId cls :: QualIdent
cls f :: Ident
f = String -> Ident
mkIdent (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ "_def#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
idName Ident
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ '#' Char -> String -> String
forall a. a -> [a] -> [a]
: QualIdent -> String
qualName QualIdent
cls

qDefaultMethodId :: QualIdent -> Ident -> QualIdent
qDefaultMethodId :: QualIdent -> Ident -> QualIdent
qDefaultMethodId cls :: QualIdent
cls = QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
cls (Ident -> QualIdent) -> (Ident -> Ident) -> Ident -> QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> Ident -> Ident
defaultMethodId QualIdent
cls

superDictStubId :: QualIdent -> QualIdent -> Ident
superDictStubId :: QualIdent -> QualIdent -> Ident
superDictStubId cls :: QualIdent
cls scls :: QualIdent
scls = String -> Ident
mkIdent (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$
  "_super#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
qualName QualIdent
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++ '#' Char -> String -> String
forall a. a -> [a] -> [a]
: QualIdent -> String
qualName QualIdent
scls

qSuperDictStubId :: QualIdent -> QualIdent -> QualIdent
qSuperDictStubId :: QualIdent -> QualIdent -> QualIdent
qSuperDictStubId cls :: QualIdent
cls = QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
cls (Ident -> QualIdent)
-> (QualIdent -> Ident) -> QualIdent -> QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> QualIdent -> Ident
superDictStubId QualIdent
cls

instFunId :: QualIdent -> Type -> Ident
instFunId :: QualIdent -> Type -> Ident
instFunId cls :: QualIdent
cls ty :: Type
ty = String -> Ident
mkIdent (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$
  "_inst#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
qualName QualIdent
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++ '#' Char -> String -> String
forall a. a -> [a] -> [a]
: QualIdent -> String
qualName (Type -> QualIdent
rootOfType Type
ty)

qInstFunId :: ModuleIdent -> QualIdent -> Type -> QualIdent
qInstFunId :: ModuleIdent -> QualIdent -> Type -> QualIdent
qInstFunId m :: ModuleIdent
m cls :: QualIdent
cls = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m (Ident -> QualIdent) -> (Type -> Ident) -> Type -> QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> Type -> Ident
instFunId QualIdent
cls

implMethodId :: QualIdent -> Type -> Ident -> Ident
implMethodId :: QualIdent -> Type -> Ident -> Ident
implMethodId cls :: QualIdent
cls ty :: Type
ty f :: Ident
f = String -> Ident
mkIdent (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$
  "_impl#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
idName Ident
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ '#' Char -> String -> String
forall a. a -> [a] -> [a]
: QualIdent -> String
qualName QualIdent
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++ '#' Char -> String -> String
forall a. a -> [a] -> [a]
: QualIdent -> String
qualName (Type -> QualIdent
rootOfType Type
ty)

qImplMethodId :: ModuleIdent -> QualIdent -> Type -> Ident -> QualIdent
qImplMethodId :: ModuleIdent -> QualIdent -> Type -> Ident -> QualIdent
qImplMethodId m :: ModuleIdent
m cls :: QualIdent
cls ty :: Type
ty = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m (Ident -> QualIdent) -> (Ident -> Ident) -> Ident -> QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualIdent -> Type -> Ident -> Ident
implMethodId QualIdent
cls Type
ty

-- -----------------------------------------------------------------------------
-- Generating variables
-- -----------------------------------------------------------------------------

freshVar :: String -> Type -> DTM (Type, Ident)
freshVar :: String -> Type -> StateT DTState Identity (Type, Ident)
freshVar name :: String
name ty :: Type
ty = ((,) Type
ty) (Ident -> (Type, Ident))
-> (Integer -> Ident) -> Integer -> (Type, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
mkIdent (String -> Ident) -> (Integer -> String) -> Integer -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Integer -> String) -> Integer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  Integer -> String
forall a. Show a => a -> String
show (Integer -> (Type, Ident))
-> DTM Integer -> StateT DTState Identity (Type, Ident)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DTM Integer
getNextId

-- -----------------------------------------------------------------------------
-- Auxiliary functions
-- -----------------------------------------------------------------------------

-- The function 'dictType' returns the type of the dictionary corresponding to
-- a particular C-T instance.

dictType :: Pred -> Type
dictType :: Pred -> Type
dictType (Pred cls :: QualIdent
cls ty :: Type
ty) = Type -> Type -> Type
TypeApply (QualIdent -> Type
TypeConstructor (QualIdent -> Type) -> QualIdent -> Type
forall a b. (a -> b) -> a -> b
$ QualIdent -> QualIdent
qDictTypeId QualIdent
cls) Type
ty

-- The function 'transformPredType' replaces each predicate with a new
-- dictionary type argument.

transformPredType :: PredType -> Type
transformPredType :: PredType -> Type
transformPredType (PredType ps :: PredSet
ps ty :: Type
ty) =
  (Pred -> Type -> Type) -> Type -> [Pred] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
TypeArrow (Type -> Type -> Type) -> (Pred -> Type) -> Pred -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pred -> Type
dictType) Type
ty ([Pred] -> Type) -> [Pred] -> Type
forall a b. (a -> b) -> a -> b
$ PredSet -> [Pred]
forall a. Set a -> [a]
Set.toList PredSet
ps

-- The function 'transformMethodPredType' first deletes the implicit class
-- constraint and then transforms the resulting predicated type as above.

transformMethodPredType :: PredType -> Type
transformMethodPredType :: PredType -> Type
transformMethodPredType (PredType ps :: PredSet
ps ty :: Type
ty) =
  PredType -> Type
transformPredType (PredType -> Type) -> PredType -> Type
forall a b. (a -> b) -> a -> b
$ PredSet -> Type -> PredType
PredType (PredSet -> PredSet
forall a. Set a -> Set a
Set.deleteMin PredSet
ps) Type
ty

-- The function 'generalizeMethodType' generalizes an already transformed
-- method type to a forall type by quantifying all occuring type variables
-- except for the class variable whose index is 0.
generalizeMethodType :: Type -> Type
generalizeMethodType :: Type -> Type
generalizeMethodType ty :: Type
ty
  | [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
tvs  = Type
ty
  | Bool
otherwise = [Int] -> Type -> Type
TypeForall [Int]
tvs Type
ty
  where tvs :: [Int]
tvs = [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Type -> [Int]
forall t. IsType t => t -> [Int]
typeVars Type
ty

instTypeVar :: Int -> Int
instTypeVar :: Int -> Int
instTypeVar tv :: Int
tv = -1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tv

instType :: Type -> Type
instType :: Type -> Type
instType (TypeConstructor tc :: QualIdent
tc) = QualIdent -> Type
TypeConstructor QualIdent
tc
instType (TypeVariable    tv :: Int
tv) = Int -> Type
TypeVariable (Int -> Int
instTypeVar Int
tv)
instType (TypeApply  ty1 :: Type
ty1 ty2 :: Type
ty2) = Type -> Type -> Type
TypeApply (Type -> Type
instType Type
ty1) (Type -> Type
instType Type
ty2)
instType (TypeArrow  ty1 :: Type
ty1 ty2 :: Type
ty2) = Type -> Type -> Type
TypeArrow (Type -> Type
instType Type
ty1) (Type -> Type
instType Type
ty2)
instType (TypeForall  tvs :: [Int]
tvs ty :: Type
ty) = [Int] -> Type -> Type
TypeForall ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
instTypeVar [Int]
tvs) (Type -> Type
instType Type
ty)
instType ty :: Type
ty = Type
ty

instPred :: Pred -> Pred
instPred :: Pred -> Pred
instPred (Pred cls :: QualIdent
cls ty :: Type
ty) = QualIdent -> Type -> Pred
Pred QualIdent
cls (Type -> Type
instType Type
ty)

unRenameIdentIf :: Bool -> Ident -> Ident
unRenameIdentIf :: Bool -> Ident -> Ident
unRenameIdentIf b :: Bool
b = if Bool
b then Ident -> Ident
unRenameIdent else Ident -> Ident
forall a. a -> a
id

-- The string for the error message for a class method's default method
-- implementation has to be constructed in its desugared form since the
-- desugaring has already taken place.

preludeError :: Type -> String -> Expression PredType
preludeError :: Type -> String -> Expression PredType
preludeError a :: Type
a =
  SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo
                     (Type -> PredType
predType (Type -> Type -> Type
TypeArrow Type
stringType Type
a)) QualIdent
qErrorId) (Expression PredType -> Expression PredType)
-> (String -> Expression PredType) -> String -> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Expression PredType
stringExpr

stringExpr :: String -> Expression PredType
stringExpr :: String -> Expression PredType
stringExpr = (Char -> Expression PredType -> Expression PredType)
-> Expression PredType -> String -> Expression PredType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Expression PredType -> Expression PredType -> Expression PredType
consExpr (Expression PredType -> Expression PredType -> Expression PredType)
-> (Char -> Expression PredType)
-> Char
-> Expression PredType
-> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo (Type -> PredType
predType Type
charType) (Literal -> Expression PredType)
-> (Char -> Literal) -> Char -> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Literal
Char)
               Expression PredType
nilExpr
  where
  nilExpr :: Expression PredType
nilExpr = SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo (Type -> PredType
predType Type
stringType) QualIdent
qNilId
  consExpr :: Expression PredType -> Expression PredType -> Expression PredType
consExpr = (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo) (Expression PredType -> Expression PredType -> Expression PredType)
-> (Expression PredType -> Expression PredType)
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
    (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
consType Type
charType) QualIdent
qConsId)

-- The function 'varType' is able to lookup both local and global identifiers.
-- Since the environments have been qualified before, global declarations are
-- only visible under their original name whereas local declarations are always
-- entered unqualified.

varType :: ModuleIdent -> Ident -> ValueEnv -> TypeScheme
varType :: ModuleIdent -> Ident -> ValueEnv -> TypeScheme
varType m :: ModuleIdent
m v :: Ident
v vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue (Ident -> QualIdent
qualify Ident
v) ValueEnv
vEnv of
  Value _ _ _ tySc :: TypeScheme
tySc : _ -> TypeScheme
tySc
  Label _ _   tySc :: TypeScheme
tySc : _ -> TypeScheme
tySc
  _ -> case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
v) ValueEnv
vEnv of
    Value _ _ _ tySc :: TypeScheme
tySc : _ -> TypeScheme
tySc
    Label _ _   tySc :: TypeScheme
tySc : _ -> TypeScheme
tySc
    _ -> String -> TypeScheme
forall a. String -> a
internalError (String -> TypeScheme) -> String -> TypeScheme
forall a b. (a -> b) -> a -> b
$ "Dictionary.varType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
forall a. Show a => a -> String
show Ident
v

conType :: QualIdent -> ValueEnv -> TypeScheme
conType :: QualIdent -> ValueEnv -> TypeScheme
conType c :: QualIdent
c vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
c ValueEnv
vEnv of
  [DataConstructor  _ _ _ (ForAll n :: Int
n pty :: PredType
pty)] -> Int -> PredType -> TypeScheme
ForAll Int
n PredType
pty
  [NewtypeConstructor _ _ (ForAll n :: Int
n pty :: PredType
pty)] -> Int -> PredType -> TypeScheme
ForAll Int
n PredType
pty
  _ -> String -> TypeScheme
forall a. String -> a
internalError (String -> TypeScheme) -> String -> TypeScheme
forall a b. (a -> b) -> a -> b
$ "Dictionary.conType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
c

funType :: QualIdent -> ValueEnv -> TypeScheme
funType :: QualIdent -> ValueEnv -> TypeScheme
funType f :: QualIdent
f vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
f ValueEnv
vEnv of
  [Value _ _ _ tySc :: TypeScheme
tySc] -> TypeScheme
tySc
  [Label _ _   tySc :: TypeScheme
tySc] -> TypeScheme
tySc
  _ -> String -> TypeScheme
forall a. String -> a
internalError (String -> TypeScheme) -> String -> TypeScheme
forall a b. (a -> b) -> a -> b
$ "Dictionary.funType " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
f

opType :: QualIdent -> ValueEnv -> TypeScheme
opType :: QualIdent -> ValueEnv -> TypeScheme
opType op :: QualIdent
op vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
op ValueEnv
vEnv of
  [DataConstructor  _ _ _ (ForAll n :: Int
n pty :: PredType
pty)] -> Int -> PredType -> TypeScheme
ForAll Int
n PredType
pty
  [NewtypeConstructor _ _ (ForAll n :: Int
n pty :: PredType
pty)] -> Int -> PredType -> TypeScheme
ForAll Int
n PredType
pty
  [Value _ _ _                             tySc :: TypeScheme
tySc] -> TypeScheme
tySc
  [Label _ _                               tySc :: TypeScheme
tySc] -> TypeScheme
tySc
  _ -> String -> TypeScheme
forall a. String -> a
internalError (String -> TypeScheme) -> String -> TypeScheme
forall a b. (a -> b) -> a -> b
$ "Dictionary.opType " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
op