module Checks.InstanceCheck (instanceCheck) where
import Control.Monad.Extra (concatMapM, whileM)
import qualified Control.Monad.State as S (State, execState, gets, modify)
import Data.List (nub, partition, sortBy)
import qualified Data.Map as Map
import qualified Data.Set.Extra as Set
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Base.SpanInfo
import Curry.Syntax hiding (impls)
import Curry.Syntax.Pretty
import Base.CurryTypes
import Base.Messages (Message, posMessage, message, internalError)
import Base.SCC (scc)
import Base.TypeExpansion
import Base.Types
import Base.TypeSubst
import Base.Utils (fst3, snd3, findMultiples)
import Env.Class
import Env.Instance
import Env.TypeConstructor
instanceCheck :: ModuleIdent -> TCEnv -> ClassEnv -> InstEnv -> [Decl a]
-> (InstEnv, [Message])
instanceCheck :: ModuleIdent
-> TCEnv -> ClassEnv -> InstEnv -> [Decl a] -> (InstEnv, [Message])
instanceCheck m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv inEnv :: InstEnv
inEnv ds :: [Decl a]
ds =
case [InstSource] -> [[InstSource]]
forall a. Eq a => [a] -> [[a]]
findMultiples ([InstSource]
local [InstSource] -> [InstSource] -> [InstSource]
forall a. [a] -> [a] -> [a]
++ [InstSource]
imported) of
[] -> INCM () -> INCState -> (InstEnv, [Message])
forall a. INCM a -> INCState -> (InstEnv, [Message])
execINCM (TCEnv -> ClassEnv -> [Decl a] -> INCM ()
forall a. TCEnv -> ClassEnv -> [Decl a] -> INCM ()
checkDecls TCEnv
tcEnv ClassEnv
clsEnv [Decl a]
ds) INCState
state
iss :: [[InstSource]]
iss -> (InstEnv
inEnv, ([InstSource] -> Message) -> [[InstSource]] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map (TCEnv -> [InstSource] -> Message
errMultipleInstances TCEnv
tcEnv) [[InstSource]]
iss)
where
local :: [InstSource]
local = (InstIdent -> InstSource) -> [InstIdent] -> [InstSource]
forall a b. (a -> b) -> [a] -> [b]
map ((InstIdent -> ModuleIdent -> InstSource)
-> ModuleIdent -> InstIdent -> InstSource
forall a b c. (a -> b -> c) -> b -> a -> c
flip InstIdent -> ModuleIdent -> InstSource
InstSource ModuleIdent
m) ([InstIdent] -> [InstSource]) -> [InstIdent] -> [InstSource]
forall a b. (a -> b) -> a -> b
$ (Decl a -> [InstIdent]) -> [Decl a] -> [InstIdent]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleIdent -> TCEnv -> Decl a -> [InstIdent]
forall a. ModuleIdent -> TCEnv -> Decl a -> [InstIdent]
genInstIdents ModuleIdent
m TCEnv
tcEnv) [Decl a]
ds
imported :: [InstSource]
imported = ((InstIdent, ModuleIdent) -> InstSource)
-> [(InstIdent, ModuleIdent)] -> [InstSource]
forall a b. (a -> b) -> [a] -> [b]
map ((InstIdent -> ModuleIdent -> InstSource)
-> (InstIdent, ModuleIdent) -> InstSource
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry InstIdent -> ModuleIdent -> InstSource
InstSource) ([(InstIdent, ModuleIdent)] -> [InstSource])
-> [(InstIdent, ModuleIdent)] -> [InstSource]
forall a b. (a -> b) -> a -> b
$ ((InstIdent, (ModuleIdent, PredSet, [(Ident, Int)]))
-> (InstIdent, ModuleIdent))
-> [(InstIdent, (ModuleIdent, PredSet, [(Ident, Int)]))]
-> [(InstIdent, ModuleIdent)]
forall a b. (a -> b) -> [a] -> [b]
map (((ModuleIdent, PredSet, [(Ident, Int)]) -> ModuleIdent)
-> (InstIdent, (ModuleIdent, PredSet, [(Ident, Int)]))
-> (InstIdent, ModuleIdent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModuleIdent, PredSet, [(Ident, Int)]) -> ModuleIdent
forall a b c. (a, b, c) -> a
fst3) ([(InstIdent, (ModuleIdent, PredSet, [(Ident, Int)]))]
-> [(InstIdent, ModuleIdent)])
-> [(InstIdent, (ModuleIdent, PredSet, [(Ident, Int)]))]
-> [(InstIdent, ModuleIdent)]
forall a b. (a -> b) -> a -> b
$ InstEnv -> [(InstIdent, (ModuleIdent, PredSet, [(Ident, Int)]))]
forall k a. Map k a -> [(k, a)]
Map.toList InstEnv
inEnv
state :: INCState
state = ModuleIdent -> InstEnv -> [Message] -> INCState
INCState ModuleIdent
m InstEnv
inEnv []
data InstSource = InstSource InstIdent ModuleIdent
instance Eq InstSource where
InstSource i1 :: InstIdent
i1 _ == :: InstSource -> InstSource -> Bool
== InstSource i2 :: InstIdent
i2 _ = InstIdent
i1 InstIdent -> InstIdent -> Bool
forall a. Eq a => a -> a -> Bool
== InstIdent
i2
type INCM = S.State INCState
data INCState = INCState
{ INCState -> ModuleIdent
moduleIdent :: ModuleIdent
, INCState -> InstEnv
instEnv :: InstEnv
, INCState -> [Message]
errors :: [Message]
}
execINCM :: INCM a -> INCState -> (InstEnv, [Message])
execINCM :: INCM a -> INCState -> (InstEnv, [Message])
execINCM incm :: INCM a
incm s :: INCState
s =
let s' :: INCState
s' = INCM a -> INCState -> INCState
forall s a. State s a -> s -> s
S.execState INCM a
incm INCState
s in (INCState -> InstEnv
instEnv INCState
s', [Message] -> [Message]
forall a. [a] -> [a]
reverse ([Message] -> [Message]) -> [Message] -> [Message]
forall a b. (a -> b) -> a -> b
$ [Message] -> [Message]
forall a. Eq a => [a] -> [a]
nub ([Message] -> [Message]) -> [Message] -> [Message]
forall a b. (a -> b) -> a -> b
$ INCState -> [Message]
errors INCState
s')
getModuleIdent :: INCM ModuleIdent
getModuleIdent :: INCM ModuleIdent
getModuleIdent = (INCState -> ModuleIdent) -> INCM ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets INCState -> ModuleIdent
moduleIdent
getInstEnv :: INCM InstEnv
getInstEnv :: INCM InstEnv
getInstEnv = (INCState -> InstEnv) -> INCM InstEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets INCState -> InstEnv
instEnv
modifyInstEnv :: (InstEnv -> InstEnv) -> INCM ()
modifyInstEnv :: (InstEnv -> InstEnv) -> INCM ()
modifyInstEnv f :: InstEnv -> InstEnv
f = (INCState -> INCState) -> INCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((INCState -> INCState) -> INCM ())
-> (INCState -> INCState) -> INCM ()
forall a b. (a -> b) -> a -> b
$ \s :: INCState
s -> INCState
s { instEnv :: InstEnv
instEnv = InstEnv -> InstEnv
f (InstEnv -> InstEnv) -> InstEnv -> InstEnv
forall a b. (a -> b) -> a -> b
$ INCState -> InstEnv
instEnv INCState
s }
report :: Message -> INCM ()
report :: Message -> INCM ()
report err :: Message
err = (INCState -> INCState) -> INCM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify (\s :: INCState
s -> INCState
s { errors :: [Message]
errors = Message
err Message -> [Message] -> [Message]
forall a. a -> [a] -> [a]
: INCState -> [Message]
errors INCState
s })
ok :: INCM ()
ok :: INCM ()
ok = () -> INCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDecls :: TCEnv -> ClassEnv -> [Decl a] -> INCM ()
checkDecls :: TCEnv -> ClassEnv -> [Decl a] -> INCM ()
checkDecls tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv ds :: [Decl a]
ds = do
(Decl a -> INCM ()) -> [Decl a] -> INCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TCEnv -> ClassEnv -> Decl a -> INCM ()
forall a. TCEnv -> ClassEnv -> Decl a -> INCM ()
bindInstance TCEnv
tcEnv ClassEnv
clsEnv) [Decl a]
ids
(Decl a -> StateT INCState Identity DeriveInfo)
-> [Decl a] -> StateT INCState Identity [DeriveInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TCEnv -> ClassEnv -> Decl a -> StateT INCState Identity DeriveInfo
forall a.
TCEnv -> ClassEnv -> Decl a -> StateT INCState Identity DeriveInfo
declDeriveInfo TCEnv
tcEnv ClassEnv
clsEnv) ((Decl a -> Bool) -> [Decl a] -> [Decl a]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl a -> Bool
forall a. Decl a -> Bool
hasDerivedInstances [Decl a]
tds) StateT INCState Identity [DeriveInfo]
-> ([DeriveInfo] -> INCM ()) -> INCM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
([DeriveInfo] -> INCM ()) -> [[DeriveInfo]] -> INCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ClassEnv -> [DeriveInfo] -> INCM ()
bindDerivedInstances ClassEnv
clsEnv) ([[DeriveInfo]] -> INCM ())
-> ([DeriveInfo] -> [[DeriveInfo]]) -> [DeriveInfo] -> INCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DeriveInfo] -> [[DeriveInfo]]
groupDeriveInfos
(Decl a -> INCM ()) -> [Decl a] -> INCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TCEnv -> ClassEnv -> Decl a -> INCM ()
forall a. TCEnv -> ClassEnv -> Decl a -> INCM ()
checkInstance TCEnv
tcEnv ClassEnv
clsEnv) [Decl a]
ids
(Decl a -> INCM ()) -> [Decl a] -> INCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TCEnv -> ClassEnv -> Decl a -> INCM ()
forall a. TCEnv -> ClassEnv -> Decl a -> INCM ()
checkDefault TCEnv
tcEnv ClassEnv
clsEnv) [Decl a]
dds
where (tds :: [Decl a]
tds, ods :: [Decl a]
ods) = (Decl a -> Bool) -> [Decl a] -> ([Decl a], [Decl a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Decl a -> Bool
forall a. Decl a -> Bool
isTypeDecl [Decl a]
ds
ids :: [Decl a]
ids = (Decl a -> Bool) -> [Decl a] -> [Decl a]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl a -> Bool
forall a. Decl a -> Bool
isInstanceDecl [Decl a]
ods
dds :: [Decl a]
dds = (Decl a -> Bool) -> [Decl a] -> [Decl a]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl a -> Bool
forall a. Decl a -> Bool
isDefaultDecl [Decl a]
ods
bindInstance :: TCEnv -> ClassEnv -> Decl a -> INCM ()
bindInstance :: TCEnv -> ClassEnv -> Decl a -> INCM ()
bindInstance tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv (InstanceDecl _ cx :: Context
cx qcls :: QualIdent
qcls inst :: InstanceType
inst ds :: [Decl a]
ds) = do
ModuleIdent
m <- INCM ModuleIdent
getModuleIdent
let PredType ps :: PredSet
ps _ = ModuleIdent -> TCEnv -> ClassEnv -> QualTypeExpr -> PredType
expandPolyType ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv (QualTypeExpr -> PredType) -> QualTypeExpr -> PredType
forall a b. (a -> b) -> a -> b
$
SpanInfo -> Context -> InstanceType -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo Context
cx InstanceType
inst
(InstEnv -> InstEnv) -> INCM ()
modifyInstEnv ((InstEnv -> InstEnv) -> INCM ())
-> (InstEnv -> InstEnv) -> INCM ()
forall a b. (a -> b) -> a -> b
$
InstIdent
-> (ModuleIdent, PredSet, [(Ident, Int)]) -> InstEnv -> InstEnv
bindInstInfo (ModuleIdent -> TCEnv -> QualIdent -> InstanceType -> InstIdent
genInstIdent ModuleIdent
m TCEnv
tcEnv QualIdent
qcls InstanceType
inst) (ModuleIdent
m, PredSet
ps, [(Ident, Int)] -> [Decl a] -> [(Ident, Int)]
forall a. [(Ident, Int)] -> [Decl a] -> [(Ident, Int)]
impls [] [Decl a]
ds)
where impls :: [(Ident, Int)] -> [Decl a] -> [(Ident, Int)]
impls is :: [(Ident, Int)]
is [] = [(Ident, Int)]
is
impls is :: [(Ident, Int)]
is (FunctionDecl _ _ f :: Ident
f eqs :: [Equation a]
eqs:ds' :: [Decl a]
ds')
| Ident
f' Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Ident, Int) -> Ident) -> [(Ident, Int)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Int) -> Ident
forall a b. (a, b) -> a
fst [(Ident, Int)]
is = [(Ident, Int)] -> [Decl a] -> [(Ident, Int)]
impls [(Ident, Int)]
is [Decl a]
ds'
| Bool
otherwise = [(Ident, Int)] -> [Decl a] -> [(Ident, Int)]
impls ((Ident
f', Equation a -> Int
forall a. Equation a -> Int
eqnArity (Equation a -> Int) -> Equation a -> Int
forall a b. (a -> b) -> a -> b
$ [Equation a] -> Equation a
forall a. [a] -> a
head [Equation a]
eqs) (Ident, Int) -> [(Ident, Int)] -> [(Ident, Int)]
forall a. a -> [a] -> [a]
: [(Ident, Int)]
is) [Decl a]
ds'
where f' :: Ident
f' = Ident -> Ident
unRenameIdent Ident
f
impls _ _ = String -> [(Ident, Int)]
forall a. String -> a
internalError "InstanceCheck.bindInstance.impls"
bindInstance _ _ _ = INCM ()
ok
hasDerivedInstances :: Decl a -> Bool
hasDerivedInstances :: Decl a -> Bool
hasDerivedInstances (DataDecl _ _ _ _ clss :: [QualIdent]
clss) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [QualIdent] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QualIdent]
clss
hasDerivedInstances (NewtypeDecl _ _ _ _ clss :: [QualIdent]
clss) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [QualIdent] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QualIdent]
clss
hasDerivedInstances _ = Bool
False
data DeriveInfo = DeriveInfo Position QualIdent PredType [Type] [QualIdent]
declDeriveInfo :: TCEnv -> ClassEnv -> Decl a -> INCM DeriveInfo
declDeriveInfo :: TCEnv -> ClassEnv -> Decl a -> StateT INCState Identity DeriveInfo
declDeriveInfo tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv (DataDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs clss :: [QualIdent]
clss) =
TCEnv
-> ClassEnv
-> SpanInfo
-> Ident
-> [Ident]
-> [InstanceType]
-> [QualIdent]
-> StateT INCState Identity DeriveInfo
mkDeriveInfo TCEnv
tcEnv ClassEnv
clsEnv SpanInfo
p Ident
tc [Ident]
tvs ([[InstanceType]] -> [InstanceType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[InstanceType]]
tyss) [QualIdent]
clss
where tyss :: [[InstanceType]]
tyss = (ConstrDecl -> [InstanceType]) -> [ConstrDecl] -> [[InstanceType]]
forall a b. (a -> b) -> [a] -> [b]
map ConstrDecl -> [InstanceType]
constrDeclTypes [ConstrDecl]
cs
constrDeclTypes :: ConstrDecl -> [InstanceType]
constrDeclTypes (ConstrDecl _ _ tys :: [InstanceType]
tys) = [InstanceType]
tys
constrDeclTypes (ConOpDecl _ ty1 :: InstanceType
ty1 _ ty2 :: InstanceType
ty2) = [InstanceType
ty1, InstanceType
ty2]
constrDeclTypes (RecordDecl _ _ fs :: [FieldDecl]
fs) = [InstanceType]
tys
where tys :: [InstanceType]
tys = [InstanceType
ty | FieldDecl _ ls :: [Ident]
ls ty :: InstanceType
ty <- [FieldDecl]
fs, Ident
_ <- [Ident]
ls]
declDeriveInfo tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv (NewtypeDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs nc :: NewConstrDecl
nc clss :: [QualIdent]
clss) =
TCEnv
-> ClassEnv
-> SpanInfo
-> Ident
-> [Ident]
-> [InstanceType]
-> [QualIdent]
-> StateT INCState Identity DeriveInfo
mkDeriveInfo TCEnv
tcEnv ClassEnv
clsEnv SpanInfo
p Ident
tc [Ident]
tvs [NewConstrDecl -> InstanceType
nconstrType NewConstrDecl
nc] [QualIdent]
clss
declDeriveInfo _ _ _ =
String -> StateT INCState Identity DeriveInfo
forall a. String -> a
internalError "InstanceCheck.declDeriveInfo: no data or newtype declaration"
mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] -> [TypeExpr]
-> [QualIdent] -> INCM DeriveInfo
mkDeriveInfo :: TCEnv
-> ClassEnv
-> SpanInfo
-> Ident
-> [Ident]
-> [InstanceType]
-> [QualIdent]
-> StateT INCState Identity DeriveInfo
mkDeriveInfo tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv spi :: SpanInfo
spi tc :: Ident
tc tvs :: [Ident]
tvs tys :: [InstanceType]
tys clss :: [QualIdent]
clss = do
ModuleIdent
m <- INCM ModuleIdent
getModuleIdent
let otc :: QualIdent
otc = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
tc
oclss :: [QualIdent]
oclss = (QualIdent -> QualIdent) -> [QualIdent] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map ((QualIdent -> TCEnv -> QualIdent)
-> TCEnv -> QualIdent -> QualIdent
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName ModuleIdent
m) TCEnv
tcEnv) [QualIdent]
clss
PredType ps :: PredSet
ps ty :: Type
ty = ModuleIdent
-> TCEnv
-> ClassEnv
-> QualIdent
-> [Ident]
-> [InstanceType]
-> PredType
expandConstrType ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv QualIdent
otc [Ident]
tvs [InstanceType]
tys
(tys' :: [Type]
tys', ty' :: Type
ty') = Type -> ([Type], Type)
arrowUnapply Type
ty
DeriveInfo -> StateT INCState Identity DeriveInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (DeriveInfo -> StateT INCState Identity DeriveInfo)
-> DeriveInfo -> StateT INCState Identity DeriveInfo
forall a b. (a -> b) -> a -> b
$ Position
-> QualIdent -> PredType -> [Type] -> [QualIdent] -> DeriveInfo
DeriveInfo Position
p QualIdent
otc (PredSet -> Type -> PredType
PredType PredSet
ps Type
ty') [Type]
tys' ([QualIdent] -> DeriveInfo) -> [QualIdent] -> DeriveInfo
forall a b. (a -> b) -> a -> b
$ ClassEnv -> [QualIdent] -> [QualIdent]
sortClasses ClassEnv
clsEnv [QualIdent]
oclss
where p :: Position
p = SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
spi
sortClasses :: ClassEnv -> [QualIdent] -> [QualIdent]
sortClasses :: ClassEnv -> [QualIdent] -> [QualIdent]
sortClasses clsEnv :: ClassEnv
clsEnv clss :: [QualIdent]
clss = ((QualIdent, Int) -> QualIdent)
-> [(QualIdent, Int)] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (QualIdent, Int) -> QualIdent
forall a b. (a, b) -> a
fst ([(QualIdent, Int)] -> [QualIdent])
-> [(QualIdent, Int)] -> [QualIdent]
forall a b. (a -> b) -> a -> b
$ ((QualIdent, Int) -> (QualIdent, Int) -> Ordering)
-> [(QualIdent, Int)] -> [(QualIdent, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (QualIdent, Int) -> (QualIdent, Int) -> Ordering
forall a a a. Ord a => (a, a) -> (a, a) -> Ordering
compareDepth ([(QualIdent, Int)] -> [(QualIdent, Int)])
-> [(QualIdent, Int)] -> [(QualIdent, Int)]
forall a b. (a -> b) -> a -> b
$ (QualIdent -> (QualIdent, Int))
-> [QualIdent] -> [(QualIdent, Int)]
forall a b. (a -> b) -> [a] -> [b]
map QualIdent -> (QualIdent, Int)
adjoinDepth [QualIdent]
clss
where (_, d1 :: a
d1) compareDepth :: (a, a) -> (a, a) -> Ordering
`compareDepth` (_, d2 :: a
d2) = a
d1 a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
d2
adjoinDepth :: QualIdent -> (QualIdent, Int)
adjoinDepth cls :: QualIdent
cls = (QualIdent
cls, [QualIdent] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([QualIdent] -> Int) -> [QualIdent] -> Int
forall a b. (a -> b) -> a -> b
$ QualIdent -> ClassEnv -> [QualIdent]
allSuperClasses QualIdent
cls ClassEnv
clsEnv)
groupDeriveInfos :: [DeriveInfo] -> [[DeriveInfo]]
groupDeriveInfos :: [DeriveInfo] -> [[DeriveInfo]]
groupDeriveInfos ds :: [DeriveInfo]
ds = (DeriveInfo -> [QualIdent])
-> (DeriveInfo -> [QualIdent]) -> [DeriveInfo] -> [[DeriveInfo]]
forall b a. Eq b => (a -> [b]) -> (a -> [b]) -> [a] -> [[a]]
scc DeriveInfo -> [QualIdent]
bound DeriveInfo -> [QualIdent]
free [DeriveInfo]
ds
where bound :: DeriveInfo -> [QualIdent]
bound (DeriveInfo _ tc :: QualIdent
tc _ _ _) = [QualIdent
tc]
free :: DeriveInfo -> [QualIdent]
free (DeriveInfo _ _ _ tys :: [Type]
tys _) = (Type -> [QualIdent]) -> [Type] -> [QualIdent]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [QualIdent]
typeConstrs [Type]
tys
bindDerivedInstances :: ClassEnv -> [DeriveInfo] -> INCM ()
bindDerivedInstances :: ClassEnv -> [DeriveInfo] -> INCM ()
bindDerivedInstances clsEnv :: ClassEnv
clsEnv dis :: [DeriveInfo]
dis = do
(DeriveInfo -> INCM ()) -> [DeriveInfo] -> INCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ClassEnv -> DeriveInfo -> INCM ()
enterInitialPredSet ClassEnv
clsEnv) [DeriveInfo]
dis
StateT INCState Identity Bool -> INCM ()
forall (m :: * -> *). Monad m => m Bool -> m ()
whileM (StateT INCState Identity Bool -> INCM ())
-> StateT INCState Identity Bool -> INCM ()
forall a b. (a -> b) -> a -> b
$ (DeriveInfo -> StateT INCState Identity [(InstIdent, PredSet)])
-> [DeriveInfo] -> StateT INCState Identity [(InstIdent, PredSet)]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (ClassEnv
-> DeriveInfo -> StateT INCState Identity [(InstIdent, PredSet)]
inferPredSets ClassEnv
clsEnv) [DeriveInfo]
dis StateT INCState Identity [(InstIdent, PredSet)]
-> ([(InstIdent, PredSet)] -> StateT INCState Identity Bool)
-> StateT INCState Identity Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(InstIdent, PredSet)] -> StateT INCState Identity Bool
updatePredSets
enterInitialPredSet :: ClassEnv -> DeriveInfo -> INCM ()
enterInitialPredSet :: ClassEnv -> DeriveInfo -> INCM ()
enterInitialPredSet clsEnv :: ClassEnv
clsEnv (DeriveInfo p :: Position
p tc :: QualIdent
tc pty :: PredType
pty _ clss :: [QualIdent]
clss) =
(QualIdent -> INCM ()) -> [QualIdent] -> INCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ClassEnv
-> Position
-> QualIdent
-> PredType
-> [Type]
-> QualIdent
-> INCM ()
bindDerivedInstance ClassEnv
clsEnv Position
p QualIdent
tc PredType
pty []) [QualIdent]
clss
bindDerivedInstance :: ClassEnv -> Position -> QualIdent -> PredType -> [Type]
-> QualIdent -> INCM ()
bindDerivedInstance :: ClassEnv
-> Position
-> QualIdent
-> PredType
-> [Type]
-> QualIdent
-> INCM ()
bindDerivedInstance clsEnv :: ClassEnv
clsEnv p :: Position
p tc :: QualIdent
tc pty :: PredType
pty tys :: [Type]
tys cls :: QualIdent
cls = do
ModuleIdent
m <- INCM ModuleIdent
getModuleIdent
(i :: InstIdent
i, ps :: PredSet
ps) <- ClassEnv
-> Position
-> QualIdent
-> PredType
-> [Type]
-> QualIdent
-> INCM (InstIdent, PredSet)
inferPredSet ClassEnv
clsEnv Position
p QualIdent
tc PredType
pty [Type]
tys QualIdent
cls
(InstEnv -> InstEnv) -> INCM ()
modifyInstEnv ((InstEnv -> InstEnv) -> INCM ())
-> (InstEnv -> InstEnv) -> INCM ()
forall a b. (a -> b) -> a -> b
$ InstIdent
-> (ModuleIdent, PredSet, [(Ident, Int)]) -> InstEnv -> InstEnv
bindInstInfo InstIdent
i (ModuleIdent
m, PredSet
ps, [(Ident, Int)]
impls)
where impls :: [(Ident, Int)]
impls | QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qEqId = [(Ident
eqOpId, 2)]
| QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qOrdId = [(Ident
leqOpId, 2)]
| QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qEnumId = [ (Ident
succId, 1), (Ident
predId, 1), (Ident
toEnumId, 1)
, (Ident
fromEnumId, 1), (Ident
enumFromId, 1)
, (Ident
enumFromThenId, 2)
]
| QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qBoundedId = [(Ident
maxBoundId, 0), (Ident
minBoundId, 0)]
| QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qReadId = [(Ident
readsPrecId, 2)]
| QualIdent
cls QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qShowId = [(Ident
showsPrecId, 2)]
| Bool
otherwise =
String -> [(Ident, Int)]
forall a. String -> a
internalError "InstanceCheck.bindDerivedInstance.impls"
inferPredSets :: ClassEnv -> DeriveInfo -> INCM [(InstIdent, PredSet)]
inferPredSets :: ClassEnv
-> DeriveInfo -> StateT INCState Identity [(InstIdent, PredSet)]
inferPredSets clsEnv :: ClassEnv
clsEnv (DeriveInfo p :: Position
p tc :: QualIdent
tc pty :: PredType
pty tys :: [Type]
tys clss :: [QualIdent]
clss) =
(QualIdent -> INCM (InstIdent, PredSet))
-> [QualIdent] -> StateT INCState Identity [(InstIdent, PredSet)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ClassEnv
-> Position
-> QualIdent
-> PredType
-> [Type]
-> QualIdent
-> INCM (InstIdent, PredSet)
inferPredSet ClassEnv
clsEnv Position
p QualIdent
tc PredType
pty [Type]
tys) [QualIdent]
clss
inferPredSet :: ClassEnv -> Position -> QualIdent -> PredType -> [Type]
-> QualIdent -> INCM (InstIdent, PredSet)
inferPredSet :: ClassEnv
-> Position
-> QualIdent
-> PredType
-> [Type]
-> QualIdent
-> INCM (InstIdent, PredSet)
inferPredSet clsEnv :: ClassEnv
clsEnv p :: Position
p tc :: QualIdent
tc (PredType ps :: PredSet
ps inst :: Type
inst) tys :: [Type]
tys cls :: QualIdent
cls = do
ModuleIdent
m <- INCM ModuleIdent
getModuleIdent
let doc :: Doc
doc = ModuleIdent -> Pred -> Doc
ppPred ModuleIdent
m (Pred -> Doc) -> Pred -> Doc
forall a b. (a -> b) -> a -> b
$ QualIdent -> Type -> Pred
Pred QualIdent
cls Type
inst
sclss :: [QualIdent]
sclss = QualIdent -> ClassEnv -> [QualIdent]
superClasses QualIdent
cls ClassEnv
clsEnv
ps' :: PredSet
ps' = [Pred] -> PredSet
forall a. Ord a => [a] -> Set a
Set.fromList [QualIdent -> Type -> Pred
Pred QualIdent
cls Type
ty | Type
ty <- [Type]
tys]
ps'' :: PredSet
ps'' = [Pred] -> PredSet
forall a. Ord a => [a] -> Set a
Set.fromList [QualIdent -> Type -> Pred
Pred QualIdent
scls Type
inst | QualIdent
scls <- [QualIdent]
sclss]
ps''' :: PredSet
ps''' = PredSet
ps PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps' PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` PredSet
ps''
PredSet
ps'''' <- Position -> String -> Doc -> ClassEnv -> PredSet -> INCM PredSet
reducePredSet Position
p "derived instance" Doc
doc ClassEnv
clsEnv PredSet
ps'''
(Pred -> INCM ()) -> [Pred] -> INCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Position -> String -> Doc -> Pred -> INCM ()
reportUndecidable Position
p "derived instance" Doc
doc) ([Pred] -> INCM ()) -> [Pred] -> INCM ()
forall a b. (a -> b) -> a -> b
$ PredSet -> [Pred]
forall a. Set a -> [a]
Set.toList PredSet
ps''''
(InstIdent, PredSet) -> INCM (InstIdent, PredSet)
forall (m :: * -> *) a. Monad m => a -> m a
return ((QualIdent
cls, QualIdent
tc), PredSet
ps'''')
updatePredSets :: [(InstIdent, PredSet)] -> INCM Bool
updatePredSets :: [(InstIdent, PredSet)] -> StateT INCState Identity Bool
updatePredSets = ([Bool] -> StateT INCState Identity Bool)
-> StateT INCState Identity [Bool] -> StateT INCState Identity Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) (Bool -> StateT INCState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> StateT INCState Identity Bool)
-> ([Bool] -> Bool) -> [Bool] -> StateT INCState Identity Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or) (StateT INCState Identity [Bool] -> StateT INCState Identity Bool)
-> ([(InstIdent, PredSet)] -> StateT INCState Identity [Bool])
-> [(InstIdent, PredSet)]
-> StateT INCState Identity Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((InstIdent, PredSet) -> StateT INCState Identity Bool)
-> [(InstIdent, PredSet)] -> StateT INCState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((InstIdent -> PredSet -> StateT INCState Identity Bool)
-> (InstIdent, PredSet) -> StateT INCState Identity Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry InstIdent -> PredSet -> StateT INCState Identity Bool
updatePredSet)
updatePredSet :: InstIdent -> PredSet -> INCM Bool
updatePredSet :: InstIdent -> PredSet -> StateT INCState Identity Bool
updatePredSet i :: InstIdent
i ps :: PredSet
ps = do
InstEnv
inEnv <- INCM InstEnv
getInstEnv
case InstIdent
-> InstEnv -> Maybe (ModuleIdent, PredSet, [(Ident, Int)])
lookupInstInfo InstIdent
i InstEnv
inEnv of
Just (m :: ModuleIdent
m, ps' :: PredSet
ps', is :: [(Ident, Int)]
is)
| PredSet
ps PredSet -> PredSet -> Bool
forall a. Eq a => a -> a -> Bool
== PredSet
ps' -> Bool -> StateT INCState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise -> do
(InstEnv -> InstEnv) -> INCM ()
modifyInstEnv ((InstEnv -> InstEnv) -> INCM ())
-> (InstEnv -> InstEnv) -> INCM ()
forall a b. (a -> b) -> a -> b
$ InstIdent
-> (ModuleIdent, PredSet, [(Ident, Int)]) -> InstEnv -> InstEnv
bindInstInfo InstIdent
i (ModuleIdent
m, PredSet
ps, [(Ident, Int)]
is)
Bool -> StateT INCState Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Nothing -> String -> StateT INCState Identity Bool
forall a. String -> a
internalError "InstanceCheck.updatePredSet"
reportUndecidable :: Position -> String -> Doc -> Pred -> INCM ()
reportUndecidable :: Position -> String -> Doc -> Pred -> INCM ()
reportUndecidable p :: Position
p what :: String
what doc :: Doc
doc predicate :: Pred
predicate@(Pred _ ty :: Type
ty) = do
ModuleIdent
m <- INCM ModuleIdent
getModuleIdent
case Type
ty of
TypeVariable _ -> () -> INCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> Message -> INCM ()
report (Message -> INCM ()) -> Message -> INCM ()
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> Position -> String -> Doc -> Pred -> Message
errMissingInstance ModuleIdent
m Position
p String
what Doc
doc Pred
predicate
checkInstance :: TCEnv -> ClassEnv -> Decl a -> INCM ()
checkInstance :: TCEnv -> ClassEnv -> Decl a -> INCM ()
checkInstance tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv (InstanceDecl spi :: SpanInfo
spi cx :: Context
cx cls :: QualIdent
cls inst :: InstanceType
inst _) = do
ModuleIdent
m <- INCM ModuleIdent
getModuleIdent
let PredType ps :: PredSet
ps ty :: Type
ty = ModuleIdent -> TCEnv -> ClassEnv -> QualTypeExpr -> PredType
expandPolyType ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv (QualTypeExpr -> PredType) -> QualTypeExpr -> PredType
forall a b. (a -> b) -> a -> b
$
SpanInfo -> Context -> InstanceType -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo Context
cx InstanceType
inst
ocls :: QualIdent
ocls = ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName ModuleIdent
m QualIdent
cls TCEnv
tcEnv
ps' :: PredSet
ps' = [Pred] -> PredSet
forall a. Ord a => [a] -> Set a
Set.fromList [ QualIdent -> Type -> Pred
Pred QualIdent
scls Type
ty | QualIdent
scls <- QualIdent -> ClassEnv -> [QualIdent]
superClasses QualIdent
ocls ClassEnv
clsEnv ]
doc :: Doc
doc = ModuleIdent -> Pred -> Doc
ppPred ModuleIdent
m (Pred -> Doc) -> Pred -> Doc
forall a b. (a -> b) -> a -> b
$ QualIdent -> Type -> Pred
Pred QualIdent
cls Type
ty
what :: String
what = "instance declaration"
PredSet
ps'' <- Position -> String -> Doc -> ClassEnv -> PredSet -> INCM PredSet
reducePredSet Position
p String
what Doc
doc ClassEnv
clsEnv PredSet
ps'
(Pred -> INCM ()) -> PredSet -> INCM ()
forall (m :: * -> *) b a.
(Monad m, Ord b) =>
(a -> m b) -> Set a -> m ()
Set.mapM_ (Message -> INCM ()
report (Message -> INCM ()) -> (Pred -> Message) -> Pred -> INCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> Position -> String -> Doc -> Pred -> Message
errMissingInstance ModuleIdent
m Position
p String
what Doc
doc) (PredSet -> INCM ()) -> PredSet -> INCM ()
forall a b. (a -> b) -> a -> b
$
PredSet
ps'' PredSet -> PredSet -> PredSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` (ClassEnv -> PredSet -> PredSet
maxPredSet ClassEnv
clsEnv PredSet
ps)
where p :: Position
p = SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
spi
checkInstance _ _ _ = INCM ()
ok
checkDefault :: TCEnv -> ClassEnv -> Decl a -> INCM ()
checkDefault :: TCEnv -> ClassEnv -> Decl a -> INCM ()
checkDefault tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv (DefaultDecl p :: SpanInfo
p tys :: [InstanceType]
tys) =
(InstanceType -> INCM ()) -> [InstanceType] -> INCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Position -> TCEnv -> ClassEnv -> InstanceType -> INCM ()
checkDefaultType (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
p) TCEnv
tcEnv ClassEnv
clsEnv) [InstanceType]
tys
checkDefault _ _ _ = INCM ()
ok
checkDefaultType :: Position -> TCEnv -> ClassEnv -> TypeExpr -> INCM ()
checkDefaultType :: Position -> TCEnv -> ClassEnv -> InstanceType -> INCM ()
checkDefaultType p :: Position
p tcEnv :: TCEnv
tcEnv clsEnv :: ClassEnv
clsEnv ty :: InstanceType
ty = do
ModuleIdent
m <- INCM ModuleIdent
getModuleIdent
let PredType _ ty' :: Type
ty' = ModuleIdent -> TCEnv -> ClassEnv -> QualTypeExpr -> PredType
expandPolyType ModuleIdent
m TCEnv
tcEnv ClassEnv
clsEnv (QualTypeExpr -> PredType) -> QualTypeExpr -> PredType
forall a b. (a -> b) -> a -> b
$
SpanInfo -> Context -> InstanceType -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo [] InstanceType
ty
PredSet
ps <- Position -> String -> Doc -> ClassEnv -> PredSet -> INCM PredSet
reducePredSet Position
p String
what Doc
empty ClassEnv
clsEnv (Pred -> PredSet
forall a. a -> Set a
Set.singleton (Pred -> PredSet) -> Pred -> PredSet
forall a b. (a -> b) -> a -> b
$ QualIdent -> Type -> Pred
Pred QualIdent
qNumId Type
ty')
(Pred -> INCM ()) -> PredSet -> INCM ()
forall (m :: * -> *) b a.
(Monad m, Ord b) =>
(a -> m b) -> Set a -> m ()
Set.mapM_ (Message -> INCM ()
report (Message -> INCM ()) -> (Pred -> Message) -> Pred -> INCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> Position -> String -> Doc -> Pred -> Message
errMissingInstance ModuleIdent
m Position
p String
what Doc
empty) PredSet
ps
where what :: String
what = "default declaration"
reducePredSet :: Position -> String -> Doc -> ClassEnv -> PredSet
-> INCM PredSet
reducePredSet :: Position -> String -> Doc -> ClassEnv -> PredSet -> INCM PredSet
reducePredSet p :: Position
p what :: String
what doc :: Doc
doc clsEnv :: ClassEnv
clsEnv ps :: PredSet
ps = do
ModuleIdent
m <- INCM ModuleIdent
getModuleIdent
InstEnv
inEnv <- INCM InstEnv
getInstEnv
let (ps1 :: PredSet
ps1, ps2 :: PredSet
ps2) = PredSet -> (PredSet, PredSet)
partitionPredSet (PredSet -> (PredSet, PredSet)) -> PredSet -> (PredSet, PredSet)
forall a b. (a -> b) -> a -> b
$ ClassEnv -> PredSet -> PredSet
minPredSet ClassEnv
clsEnv (PredSet -> PredSet) -> PredSet -> PredSet
forall a b. (a -> b) -> a -> b
$ InstEnv -> PredSet -> PredSet
reducePreds InstEnv
inEnv PredSet
ps
(Pred -> INCM ()) -> PredSet -> INCM ()
forall (m :: * -> *) b a.
(Monad m, Ord b) =>
(a -> m b) -> Set a -> m ()
Set.mapM_ (Message -> INCM ()
report (Message -> INCM ()) -> (Pred -> Message) -> Pred -> INCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> Position -> String -> Doc -> Pred -> Message
errMissingInstance ModuleIdent
m Position
p String
what Doc
doc) PredSet
ps2
PredSet -> INCM PredSet
forall (m :: * -> *) a. Monad m => a -> m a
return PredSet
ps1
where
reducePreds :: InstEnv -> PredSet -> PredSet
reducePreds inEnv :: InstEnv
inEnv = (Pred -> PredSet) -> PredSet -> PredSet
forall a b. (Ord a, Ord b) => (a -> Set b) -> Set a -> Set b
Set.concatMap ((Pred -> PredSet) -> PredSet -> PredSet)
-> (Pred -> PredSet) -> PredSet -> PredSet
forall a b. (a -> b) -> a -> b
$ InstEnv -> Pred -> PredSet
reducePred InstEnv
inEnv
reducePred :: InstEnv -> Pred -> PredSet
reducePred inEnv :: InstEnv
inEnv predicate :: Pred
predicate = PredSet -> (PredSet -> PredSet) -> Maybe PredSet -> PredSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Pred -> PredSet
forall a. a -> Set a
Set.singleton Pred
predicate)
(InstEnv -> PredSet -> PredSet
reducePreds InstEnv
inEnv)
(InstEnv -> Pred -> Maybe PredSet
instPredSet InstEnv
inEnv Pred
predicate)
instPredSet :: InstEnv -> Pred -> Maybe PredSet
instPredSet :: InstEnv -> Pred -> Maybe PredSet
instPredSet inEnv :: InstEnv
inEnv (Pred qcls :: QualIdent
qcls ty :: Type
ty) =
case Bool -> Type -> (Type, [Type])
unapplyType Bool
False Type
ty of
(TypeConstructor tc :: QualIdent
tc, tys :: [Type]
tys) ->
((ModuleIdent, PredSet, [(Ident, Int)]) -> PredSet)
-> Maybe (ModuleIdent, PredSet, [(Ident, Int)]) -> Maybe PredSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Type] -> PredSet -> PredSet
forall a. ExpandAliasType a => [Type] -> a -> a
expandAliasType [Type]
tys (PredSet -> PredSet)
-> ((ModuleIdent, PredSet, [(Ident, Int)]) -> PredSet)
-> (ModuleIdent, PredSet, [(Ident, Int)])
-> PredSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleIdent, PredSet, [(Ident, Int)]) -> PredSet
forall a b c. (a, b, c) -> b
snd3) (InstIdent
-> InstEnv -> Maybe (ModuleIdent, PredSet, [(Ident, Int)])
lookupInstInfo (QualIdent
qcls, QualIdent
tc) InstEnv
inEnv)
_ -> Maybe PredSet
forall a. Maybe a
Nothing
genInstIdents :: ModuleIdent -> TCEnv -> Decl a -> [InstIdent]
genInstIdents :: ModuleIdent -> TCEnv -> Decl a -> [InstIdent]
genInstIdents m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv (DataDecl _ tc :: Ident
tc _ _ qclss :: [QualIdent]
qclss) =
(QualIdent -> InstIdent) -> [QualIdent] -> [InstIdent]
forall a b. (a -> b) -> [a] -> [b]
map ((QualIdent -> InstanceType -> InstIdent)
-> InstanceType -> QualIdent -> InstIdent
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent -> TCEnv -> QualIdent -> InstanceType -> InstIdent
genInstIdent ModuleIdent
m TCEnv
tcEnv) (InstanceType -> QualIdent -> InstIdent)
-> InstanceType -> QualIdent -> InstIdent
forall a b. (a -> b) -> a -> b
$ SpanInfo -> QualIdent -> InstanceType
ConstructorType SpanInfo
NoSpanInfo (QualIdent -> InstanceType) -> QualIdent -> InstanceType
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify Ident
tc)
[QualIdent]
qclss
genInstIdents m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv (NewtypeDecl _ tc :: Ident
tc _ _ qclss :: [QualIdent]
qclss) =
(QualIdent -> InstIdent) -> [QualIdent] -> [InstIdent]
forall a b. (a -> b) -> [a] -> [b]
map ((QualIdent -> InstanceType -> InstIdent)
-> InstanceType -> QualIdent -> InstIdent
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent -> TCEnv -> QualIdent -> InstanceType -> InstIdent
genInstIdent ModuleIdent
m TCEnv
tcEnv) (InstanceType -> QualIdent -> InstIdent)
-> InstanceType -> QualIdent -> InstIdent
forall a b. (a -> b) -> a -> b
$ SpanInfo -> QualIdent -> InstanceType
ConstructorType SpanInfo
NoSpanInfo (QualIdent -> InstanceType) -> QualIdent -> InstanceType
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify Ident
tc)
[QualIdent]
qclss
genInstIdents m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv (InstanceDecl _ _ qcls :: QualIdent
qcls ty :: InstanceType
ty _) =
[ModuleIdent -> TCEnv -> QualIdent -> InstanceType -> InstIdent
genInstIdent ModuleIdent
m TCEnv
tcEnv QualIdent
qcls InstanceType
ty]
genInstIdents _ _ _ = []
genInstIdent :: ModuleIdent -> TCEnv -> QualIdent -> TypeExpr -> InstIdent
genInstIdent :: ModuleIdent -> TCEnv -> QualIdent -> InstanceType -> InstIdent
genInstIdent m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv qcls :: QualIdent
qcls = ModuleIdent -> TCEnv -> InstIdent -> InstIdent
qualInstIdent ModuleIdent
m TCEnv
tcEnv (InstIdent -> InstIdent)
-> (InstanceType -> InstIdent) -> InstanceType -> InstIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) QualIdent
qcls (QualIdent -> InstIdent)
-> (InstanceType -> QualIdent) -> InstanceType -> InstIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstanceType -> QualIdent
typeConstr
qualInstIdent :: ModuleIdent -> TCEnv -> InstIdent -> InstIdent
qualInstIdent :: ModuleIdent -> TCEnv -> InstIdent -> InstIdent
qualInstIdent m :: ModuleIdent
m tcEnv :: TCEnv
tcEnv (cls :: QualIdent
cls, tc :: QualIdent
tc) = (QualIdent -> QualIdent
qual QualIdent
cls, QualIdent -> QualIdent
qual QualIdent
tc)
where
qual :: QualIdent -> QualIdent
qual = (QualIdent -> TCEnv -> QualIdent)
-> TCEnv -> QualIdent -> QualIdent
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleIdent -> QualIdent -> TCEnv -> QualIdent
getOrigName ModuleIdent
m) TCEnv
tcEnv
unqualInstIdent :: TCEnv -> InstIdent -> InstIdent
unqualInstIdent :: TCEnv -> InstIdent -> InstIdent
unqualInstIdent tcEnv :: TCEnv
tcEnv (qcls :: QualIdent
qcls, tc :: QualIdent
tc) = (QualIdent -> QualIdent
unqual QualIdent
qcls, QualIdent -> QualIdent
unqual QualIdent
tc)
where
unqual :: QualIdent -> QualIdent
unqual = [QualIdent] -> QualIdent
forall a. [a] -> a
head ([QualIdent] -> QualIdent)
-> (QualIdent -> [QualIdent]) -> QualIdent -> QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QualIdent -> TCEnv -> [QualIdent])
-> TCEnv -> QualIdent -> [QualIdent]
forall a b c. (a -> b -> c) -> b -> a -> c
flip QualIdent -> TCEnv -> [QualIdent]
reverseLookupByOrigName TCEnv
tcEnv
errMultipleInstances :: TCEnv -> [InstSource] -> Message
errMultipleInstances :: TCEnv -> [InstSource] -> Message
errMultipleInstances tcEnv :: TCEnv
tcEnv iss :: [InstSource]
iss = Doc -> Message
message (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "Multiple instances for the same class and type" Doc -> Doc -> Doc
$+$
Int -> Doc -> Doc
nest 2 ([Doc] -> Doc
vcat ((InstSource -> Doc) -> [InstSource] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map InstSource -> Doc
ppInstSource [InstSource]
iss))
where
ppInstSource :: InstSource -> Doc
ppInstSource (InstSource i :: InstIdent
i m :: ModuleIdent
m) = InstIdent -> Doc
ppInstIdent (TCEnv -> InstIdent -> InstIdent
unqualInstIdent TCEnv
tcEnv InstIdent
i) Doc -> Doc -> Doc
<+>
Doc -> Doc
parens (String -> Doc
text "defined in" Doc -> Doc -> Doc
<+> ModuleIdent -> Doc
ppMIdent ModuleIdent
m)
errMissingInstance :: ModuleIdent -> Position -> String -> Doc -> Pred
-> Message
errMissingInstance :: ModuleIdent -> Position -> String -> Doc -> Pred -> Message
errMissingInstance m :: ModuleIdent
m p :: Position
p what :: String
what doc :: Doc
doc predicate :: Pred
predicate = Position -> Doc -> Message
forall p. HasPosition p => p -> Doc -> Message
posMessage Position
p (Doc -> Message) -> Doc -> Message
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
[ String -> Doc
text "Missing instance for" Doc -> Doc -> Doc
<+> ModuleIdent -> Pred -> Doc
ppPred ModuleIdent
m Pred
predicate
, String -> Doc
text "in" Doc -> Doc -> Doc
<+> String -> Doc
text String
what Doc -> Doc -> Doc
<+> Doc
doc
]