{-# LANGUAGE FlexibleInstances #-}
module TypeMachine.Functions (
pick,
omit,
record,
intersection,
intersection',
union,
union',
require,
partial,
partial',
apply,
applyMany,
keysOf,
)
where
import Control.Arrow (Arrow (second))
import Control.Monad (foldM, forM, unless, when)
import Control.Monad.Writer.Strict
import qualified Data.Foldable as Set
import Data.Generics
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Language.Haskell.TH hiding (Type, bang)
import qualified Language.Haskell.TH as TH
import TypeMachine.Internal.Utils
import TypeMachine.Log
import TypeMachine.TM
import TypeMachine.Type
require :: [String] -> Type -> TM Type
require :: [TypeMachineLog] -> Type -> TM Type
require [TypeMachineLog]
fieldsNameToRequire Type
ty = do
[TypeMachineLog] -> Type -> TM ()
logUnknownFields [TypeMachineLog]
fieldsNameToRequire Type
ty
updatedFields <- ((TypeMachineLog, (Bang, Type))
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (Bang, Type)))
-> [(TypeMachineLog, (Bang, Type))]
-> WriterT [TypeMachineLog] Q [(TypeMachineLog, (Bang, Type))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((TypeMachineLog
-> (Bang, Type)
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (Bang, Type)))
-> (TypeMachineLog, (Bang, Type))
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (Bang, Type))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TypeMachineLog
-> (Bang, Type)
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (Bang, Type))
forall {a}.
TypeMachineLog
-> (a, Type)
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (a, Type))
markAsRequired) (Map TypeMachineLog (Bang, Type) -> [(TypeMachineLog, (Bang, Type))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map TypeMachineLog (Bang, Type)
-> [(TypeMachineLog, (Bang, Type))])
-> Map TypeMachineLog (Bang, Type)
-> [(TypeMachineLog, (Bang, Type))]
forall a b. (a -> b) -> a -> b
$ Type -> Map TypeMachineLog (Bang, Type)
fields Type
ty)
return ty{fields = Map.fromList updatedFields}
where
markAsRequired :: TypeMachineLog
-> (a, Type)
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (a, Type))
markAsRequired TypeMachineLog
n (a
b, AppT (ConT Name
p) Type
t)
| TypeMachineLog
n TypeMachineLog -> [TypeMachineLog] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TypeMachineLog]
fieldsNameToRequire Bool -> Bool -> Bool
&& Name -> TypeMachineLog
nameBase Name
p TypeMachineLog -> TypeMachineLog -> Bool
forall a. Eq a => a -> a -> Bool
== TypeMachineLog
"Maybe" = (TypeMachineLog, (a, Type))
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (a, Type))
forall a. a -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMachineLog
n, (a
b, Type
t))
markAsRequired TypeMachineLog
n (a, Type)
r
| TypeMachineLog
n TypeMachineLog -> [TypeMachineLog] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TypeMachineLog]
fieldsNameToRequire = TypeMachineLog -> TM ()
addLog (TypeMachineLog -> TypeMachineLog
fieldNotOptional TypeMachineLog
n) TM ()
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (a, Type))
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (a, Type))
forall a b.
WriterT [TypeMachineLog] Q a
-> WriterT [TypeMachineLog] Q b -> WriterT [TypeMachineLog] Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (TypeMachineLog, (a, Type))
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (a, Type))
forall a. a -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMachineLog
n, (a, Type)
r)
markAsRequired TypeMachineLog
n (a, Type)
r = (TypeMachineLog, (a, Type))
-> WriterT [TypeMachineLog] Q (TypeMachineLog, (a, Type))
forall a. a -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeMachineLog
n, (a, Type)
r)
pick :: [String] -> Type -> TM Type
pick :: [TypeMachineLog] -> Type -> TM Type
pick [TypeMachineLog]
namesToPick Type
ty = do
Type -> TM ()
failIfHasTypeVariables Type
ty
[TypeMachineLog] -> Type -> TM ()
logUnknownFields [TypeMachineLog]
namesToPick Type
ty
let finalType :: Type
finalType = Type
ty{fields = keepKeys namesToPick (fields ty)}
Type -> TM ()
logIfEmptyType Type
finalType
Type -> TM Type
forall a. a -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
finalType
omit :: [String] -> Type -> TM Type
omit :: [TypeMachineLog] -> Type -> TM Type
omit [TypeMachineLog]
namesToOmit Type
ty = do
Type -> TM ()
failIfHasTypeVariables Type
ty
[TypeMachineLog] -> Type -> TM ()
logUnknownFields [TypeMachineLog]
namesToOmit Type
ty
let resultType :: Type
resultType = Type
ty{fields = removeKeys namesToOmit (fields ty)}
Type -> TM ()
logIfEmptyType Type
resultType
Type -> TM Type
forall a. a -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
resultType
intersection :: Type -> Type -> TM Type
intersection :: Type -> Type -> TM Type
intersection Type
a Type
b = do
Type -> TM ()
failIfHasTypeVariables Type
a
Type -> TM ()
failIfHasTypeVariables Type
b
let finalType :: Type
finalType = Type
a{fields = Map.intersection (fields a) (fields b)}
Type -> TM ()
logIfEmptyType Type
finalType
Type -> TM Type
forall a. a -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
finalType
intersection' :: Type -> Type -> TM Type
intersection' :: Type -> Type -> TM Type
intersection' = (Type -> Type -> TM Type) -> Type -> Type -> TM Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> TM Type
intersection
{-# INLINE intersection' #-}
union :: Type -> Type -> TM Type
union :: Type -> Type -> TM Type
union Type
a Type
b = do
Type -> TM ()
failIfHasTypeVariables Type
a
Type -> TM ()
failIfHasTypeVariables Type
b
Type -> TM Type
forall a. a -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TM Type) -> Type -> TM Type
forall a b. (a -> b) -> a -> b
$ Type
a{fields = Map.union (fields a) (fields b)}
union' :: Type -> Type -> TM Type
union' :: Type -> Type -> TM Type
union' = (Type -> Type -> TM Type) -> Type -> Type -> TM Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> TM Type
union
{-# INLINE union' #-}
keysOf :: Type -> TM [String]
keysOf :: Type -> TM [TypeMachineLog]
keysOf = [TypeMachineLog] -> TM [TypeMachineLog]
forall a. a -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeMachineLog] -> TM [TypeMachineLog])
-> (Type -> [TypeMachineLog]) -> Type -> TM [TypeMachineLog]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TypeMachineLog (Bang, Type) -> [TypeMachineLog]
forall k a. Map k a -> [k]
Map.keys (Map TypeMachineLog (Bang, Type) -> [TypeMachineLog])
-> (Type -> Map TypeMachineLog (Bang, Type))
-> Type
-> [TypeMachineLog]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Map TypeMachineLog (Bang, Type)
fields
partial :: Type -> TM Type
partial :: Type -> TM Type
partial = Bool -> Type -> TM Type
partial_ Bool
False
partial' :: Type -> TM Type
partial' :: Type -> TM Type
partial' = Bool -> Type -> TM Type
partial_ Bool
True
partial_ :: Bool -> Type -> TM Type
partial_ :: Bool -> Type -> TM Type
partial_ Bool
rewrapMaybes Type
ty = do
nullableFields <- Map TypeMachineLog (Bang, Type)
-> ((Bang, Type) -> WriterT [TypeMachineLog] Q (Bang, Type))
-> WriterT [TypeMachineLog] Q (Map TypeMachineLog (Bang, Type))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Type -> Map TypeMachineLog (Bang, Type)
fields Type
ty) (((Bang, Type) -> WriterT [TypeMachineLog] Q (Bang, Type))
-> WriterT [TypeMachineLog] Q (Map TypeMachineLog (Bang, Type)))
-> ((Bang, Type) -> WriterT [TypeMachineLog] Q (Bang, Type))
-> WriterT [TypeMachineLog] Q (Map TypeMachineLog (Bang, Type))
forall a b. (a -> b) -> a -> b
$ \field :: (Bang, Type)
field@(Bang
b, Type
t) -> case Type
t of
AppT (ConT Name
w) Type
_ | Name -> TypeMachineLog
nameBase Name
w TypeMachineLog -> TypeMachineLog -> Bool
forall a. Eq a => a -> a -> Bool
== TypeMachineLog
"Maybe" Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
rewrapMaybes -> (Bang, Type) -> WriterT [TypeMachineLog] Q (Bang, Type)
forall a. a -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bang, Type)
field
Type
_ -> Q (Bang, Type) -> WriterT [TypeMachineLog] Q (Bang, Type)
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [TypeMachineLog] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Bang, Type) -> WriterT [TypeMachineLog] Q (Bang, Type))
-> Q (Bang, Type) -> WriterT [TypeMachineLog] Q (Bang, Type)
forall a b. (a -> b) -> a -> b
$ (Bang
b,) (Type -> (Bang, Type)) -> Q Type -> Q (Bang, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|Maybe $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t)|]
return ty{fields = nullableFields}
record :: [String] -> Q TH.Type -> TM Type
record :: [TypeMachineLog] -> Q Type -> TM Type
record [TypeMachineLog]
fNames Q Type
t = do
Bool -> TM () -> TM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set TypeMachineLog -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Set.length Set TypeMachineLog
fNameSet Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [TypeMachineLog] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeMachineLog]
fNames) (TM () -> TM ()) -> TM () -> TM ()
forall a b. (a -> b) -> a -> b
$
TypeMachineLog -> TM ()
addLog TypeMachineLog
duplicateKey
Bool -> TM () -> TM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([TypeMachineLog] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeMachineLog]
fNames) (TM () -> TM ()) -> TM () -> TM ()
forall a b. (a -> b) -> a -> b
$
TypeMachineLog -> TM ()
addLog TypeMachineLog
emptyResultType
fType <- Q Type -> WriterT [TypeMachineLog] Q Type
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [TypeMachineLog] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Type
t
return $ Type (mkName "_") (Map.fromSet (const (bang, fType)) fNameSet) []
where
bang :: Bang
bang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
fNameSet :: Set TypeMachineLog
fNameSet = [TypeMachineLog] -> Set TypeMachineLog
forall a. Ord a => [a] -> Set a
Set.fromList [TypeMachineLog]
fNames
apply :: Q TH.Type -> Type -> TM Type
apply :: Q Type -> Type -> TM Type
apply Q Type
_ ty :: Type
ty@(Type Name
_ Map TypeMachineLog (Bang, Type)
_ []) = [TypeMachineLog] -> TM ()
addLogs [TypeMachineLog
noTypeParameter] TM () -> TM Type -> TM Type
forall a b.
WriterT [TypeMachineLog] Q a
-> WriterT [TypeMachineLog] Q b -> WriterT [TypeMachineLog] Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> TM Type
forall a. a -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
apply Q Type
qt ty :: Type
ty@(Type Name
_ Map TypeMachineLog (Bang, Type)
f ((TypeMachineLog
tp, Maybe Type
_) : [(TypeMachineLog, Maybe Type)]
tps)) = do
typeParameterValue <- Q Type -> WriterT [TypeMachineLog] Q Type
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [TypeMachineLog] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Type
qt
let fieldsWithTypeApplied = (Type -> Type) -> (Bang, Type) -> (Bang, Type)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (TypeMachineLog -> Type -> Type -> Type
forall {a}. Data a => TypeMachineLog -> Type -> a -> a
replaceTypeVar TypeMachineLog
tp Type
typeParameterValue) ((Bang, Type) -> (Bang, Type))
-> Map TypeMachineLog (Bang, Type)
-> Map TypeMachineLog (Bang, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TypeMachineLog (Bang, Type)
f
return ty{fields = fieldsWithTypeApplied, typeParams = tps}
where
replaceTypeVar :: TypeMachineLog -> Type -> a -> a
replaceTypeVar TypeMachineLog
varName Type
value a
src =
let
mapper :: Type -> Type
mapper t :: Type
t@(VarT Name
n) =
if Name -> TypeMachineLog
nameBase Name
n TypeMachineLog -> TypeMachineLog -> Bool
forall a. Eq a => a -> a -> Bool
== TypeMachineLog
varName
then Type
value
else Type
t
mapper Type
t = Type
t
in
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Type -> Type) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Type -> Type
mapper) a
src
applyMany :: [Q TH.Type] -> Type -> TM Type
applyMany :: [Q Type] -> Type -> TM Type
applyMany [Q Type]
typeArgs Type
ty = (Type -> Q Type -> TM Type) -> Type -> [Q Type] -> TM Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((Q Type -> Type -> TM Type) -> Type -> Q Type -> TM Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Q Type -> Type -> TM Type
apply) Type
ty [Q Type]
typeArgs
logUnknownFields :: [String] -> Type -> TM ()
logUnknownFields :: [TypeMachineLog] -> Type -> TM ()
logUnknownFields [TypeMachineLog]
fieldNames Type
ty =
[TypeMachineLog] -> TM ()
addLogs ([TypeMachineLog] -> TM ()) -> [TypeMachineLog] -> TM ()
forall a b. (a -> b) -> a -> b
$
TypeMachineLog -> TypeMachineLog
fieldNotInType (TypeMachineLog -> TypeMachineLog)
-> [TypeMachineLog] -> [TypeMachineLog]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeMachineLog -> Bool) -> [TypeMachineLog] -> [TypeMachineLog]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TypeMachineLog
fName -> Bool -> Bool
not (TypeMachineLog
fName TypeMachineLog -> Type -> Bool
`hasField` Type
ty)) [TypeMachineLog]
fieldNames
logIfEmptyType :: Type -> TM ()
logIfEmptyType :: Type -> TM ()
logIfEmptyType Type
ty = Bool -> TM () -> TM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map TypeMachineLog (Bang, Type) -> Bool
forall k a. Map k a -> Bool
Map.null (Map TypeMachineLog (Bang, Type) -> Bool)
-> Map TypeMachineLog (Bang, Type) -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Map TypeMachineLog (Bang, Type)
fields Type
ty) (TM () -> TM ()) -> TM () -> TM ()
forall a b. (a -> b) -> a -> b
$ TypeMachineLog -> TM ()
addLog TypeMachineLog
emptyResultType
failIfHasTypeVariables :: Type -> TM ()
failIfHasTypeVariables :: Type -> TM ()
failIfHasTypeVariables Type
ty =
Bool -> TM () -> TM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(TypeMachineLog, Maybe Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(TypeMachineLog, Maybe Type)] -> Bool)
-> [(TypeMachineLog, Maybe Type)] -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> [(TypeMachineLog, Maybe Type)]
typeParams Type
ty) (TM () -> TM ()) -> TM () -> TM ()
forall a b. (a -> b) -> a -> b
$
TypeMachineLog -> TM ()
forall a. TypeMachineLog -> WriterT [TypeMachineLog] Q a
forall (m :: * -> *) a. MonadFail m => TypeMachineLog -> m a
fail TypeMachineLog
"Warning - The behaviour of this function is not tested on types with type parameters."