further simplified from ~/svn/MagicHaskeller/allifdefs/FMType.lhs

\begin{code}
{-# OPTIONS -cpp #-}
module MagicHaskeller.FMType(FMType(..), updateFMT, unionFMT, unitFMT, lookupFMT, fmtToList, eltsFMT,
              {- listToFMT, -} mapFMT
             ) where
import MagicHaskeller.Types
-- import Monad
import Data.IntMap as IM

-- import CoreLang

#ifdef SEMIGROUP
import Data.Semigroup
#endif
import Data.Monoid

data FMType a = EmptyFMT
              | FMT {
                     FMType a -> IntMap a
tvFMT :: IntMap a,
                     FMType a -> IntMap a
tcFMT :: IntMap a,
                     FMType a -> FMType (FMType a)
taFMT  :: (FMType (FMType a)),
                     FMType a -> FMType (FMType a)
fnFMT  :: (FMType (FMType a)),
                     FMType a -> FMType (FMType a)
funFMT :: (FMType (FMType a))
                    }
                deriving (ReadPrec [FMType a]
ReadPrec (FMType a)
Int -> ReadS (FMType a)
ReadS [FMType a]
(Int -> ReadS (FMType a))
-> ReadS [FMType a]
-> ReadPrec (FMType a)
-> ReadPrec [FMType a]
-> Read (FMType a)
forall a. Read a => ReadPrec [FMType a]
forall a. Read a => ReadPrec (FMType a)
forall a. Read a => Int -> ReadS (FMType a)
forall a. Read a => ReadS [FMType a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FMType a]
$creadListPrec :: forall a. Read a => ReadPrec [FMType a]
readPrec :: ReadPrec (FMType a)
$creadPrec :: forall a. Read a => ReadPrec (FMType a)
readList :: ReadS [FMType a]
$creadList :: forall a. Read a => ReadS [FMType a]
readsPrec :: Int -> ReadS (FMType a)
$creadsPrec :: forall a. Read a => Int -> ReadS (FMType a)
Read, Int -> FMType a -> ShowS
[FMType a] -> ShowS
FMType a -> String
(Int -> FMType a -> ShowS)
-> (FMType a -> String) -> ([FMType a] -> ShowS) -> Show (FMType a)
forall a. Show a => Int -> FMType a -> ShowS
forall a. Show a => [FMType a] -> ShowS
forall a. Show a => FMType a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FMType a] -> ShowS
$cshowList :: forall a. Show a => [FMType a] -> ShowS
show :: FMType a -> String
$cshow :: forall a. Show a => FMType a -> String
showsPrec :: Int -> FMType a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FMType a -> ShowS
Show)

lookupFMT :: Type -> FMType a -> Maybe a
lookupFMT :: Type -> FMType a -> Maybe a
lookupFMT Type
_ FMType a
EmptyFMT = Maybe a
forall a. Maybe a
Nothing
lookupFMT (TV TyVar
tv)     FMType a
fmt = Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IM.lookup (TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
tv) (FMType a -> IntMap a
forall a. FMType a -> IntMap a
tvFMT FMType a
fmt)
lookupFMT (TC TyVar
tc)     FMType a
fmt = Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IM.lookup (TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
tc) (FMType a -> IntMap a
forall a. FMType a -> IntMap a
tcFMT FMType a
fmt)
lookupFMT (TA Type
t0 Type
t1)  FMType a
fmt = Type -> Type -> FMType (FMType a) -> Maybe a
forall b. Type -> Type -> FMType (FMType b) -> Maybe b
lookupFMTFMT Type
t0 Type
t1 (FMType a -> FMType (FMType a)
forall a. FMType a -> FMType (FMType a)
taFMT FMType a
fmt)
#ifdef RIGHTFMT
lookupFMT (t0 :>  t1) fmt = lookupFMTFMT t0 t1 (fnFMT fmt)
lookupFMT (t0 :-> t1) fmt = lookupFMTFMT t0 t1 (funFMT fmt)
#else
lookupFMT (Type
t1 :>  Type
t0) FMType a
fmt = Type -> Type -> FMType (FMType a) -> Maybe a
forall b. Type -> Type -> FMType (FMType b) -> Maybe b
lookupFMTFMT Type
t0 Type
t1 (FMType a -> FMType (FMType a)
forall a. FMType a -> FMType (FMType a)
fnFMT FMType a
fmt)
lookupFMT (Type
t1 :-> Type
t0) FMType a
fmt = Type -> Type -> FMType (FMType a) -> Maybe a
forall b. Type -> Type -> FMType (FMType b) -> Maybe b
lookupFMTFMT Type
t0 Type
t1 (FMType a -> FMType (FMType a)
forall a. FMType a -> FMType (FMType a)
funFMT FMType a
fmt)
#endif
lookupFMTFMT :: Type -> Type -> FMType (FMType b) -> Maybe b
lookupFMTFMT Type
t0 Type
t1 FMType (FMType b)
fmtfmt = Type -> FMType (FMType b) -> Maybe (FMType b)
forall a. Type -> FMType a -> Maybe a
lookupFMT Type
t0 FMType (FMType b)
fmtfmt Maybe (FMType b) -> (FMType b -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> FMType b -> Maybe b
forall a. Type -> FMType a -> Maybe a
lookupFMT Type
t1

mapFMT :: (Type -> a -> b) -> FMType a -> FMType b -- takes the index as an argument, like mapFM, but currently only the structures of the types are considered. 
mapFMT :: (Type -> a -> b) -> FMType a -> FMType b
mapFMT Type -> a -> b
f FMType a
EmptyFMT = FMType b
forall a. FMType a
EmptyFMT
mapFMT Type -> a -> b
f (FMT IntMap a
v IntMap a
c FMType (FMType a)
a FMType (FMType a)
n FMType (FMType a)
u) = IntMap b
-> IntMap b
-> FMType (FMType b)
-> FMType (FMType b)
-> FMType (FMType b)
-> FMType b
forall a.
IntMap a
-> IntMap a
-> FMType (FMType a)
-> FMType (FMType a)
-> FMType (FMType a)
-> FMType a
FMT ((Int -> a -> b) -> IntMap a -> IntMap b
forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
mapWithKey (\Int
tv -> Type -> a -> b
f (TyVar -> Type
TV (TyVar -> Type) -> TyVar -> Type
forall a b. (a -> b) -> a -> b
$ Int -> TyVar
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tv)) IntMap a
v)
                               ((Int -> a -> b) -> IntMap a -> IntMap b
forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
mapWithKey (\Int
tc -> Type -> a -> b
f (TyVar -> Type
TC (TyVar -> Type) -> TyVar -> Type
forall a b. (a -> b) -> a -> b
$ Int -> TyVar
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tc)) IntMap a
c)
                               ((Type -> FMType a -> FMType b)
-> FMType (FMType a) -> FMType (FMType b)
forall a b. (Type -> a -> b) -> FMType a -> FMType b
mapFMT (\Type
t0 -> (Type -> a -> b) -> FMType a -> FMType b
forall a b. (Type -> a -> b) -> FMType a -> FMType b
mapFMT (\Type
t1 -> Type -> a -> b
f (Type -> Type -> Type
TA Type
t0 Type
t1)))  FMType (FMType a)
a)
                               ((Type -> FMType a -> FMType b)
-> FMType (FMType a) -> FMType (FMType b)
forall a b. (Type -> a -> b) -> FMType a -> FMType b
mapFMT (\Type
t0 -> (Type -> a -> b) -> FMType a -> FMType b
forall a b. (Type -> a -> b) -> FMType a -> FMType b
mapFMT (\Type
t1 -> Type -> a -> b
f (Type
t1 Type -> Type -> Type
:> Type
t0)))  FMType (FMType a)
n)
                               ((Type -> FMType a -> FMType b)
-> FMType (FMType a) -> FMType (FMType b)
forall a b. (Type -> a -> b) -> FMType a -> FMType b
mapFMT (\Type
t0 -> (Type -> a -> b) -> FMType a -> FMType b
forall a b. (Type -> a -> b) -> FMType a -> FMType b
mapFMT (\Type
t1 -> Type -> a -> b
f (Type
t1 Type -> Type -> Type
:-> Type
t0))) FMType (FMType a)
u)

{- addToFMT$B$H(BlistToFMT$B$C$F2?$G%3%a%s%H%"%&%H$7$?$s$@$C$1!)(B $B$"$H!$(Bnormalize$B$7$J$$J}$,$h$$!)(B
addToFMT :: Typed a -> FMType a -> FMType a
addToFMT (e:::ty) = updateFMT (et:) et nty
    where nty = normalize ty
          et  = e:nty
listToFMT :: [Typed a] -> FMType a
listToFMT = foldr addToFMT EmptyFMT
-}


eltsFMT :: FMType a -> [a]
eltsFMT :: FMType a -> [a]
eltsFMT FMType a
EmptyFMT = []
eltsFMT (FMT IntMap a
vs IntMap a
cs FMType (FMType a)
as FMType (FMType a)
fs FMType (FMType a)
fus) = IntMap a -> [a]
forall a. IntMap a -> [a]
elems IntMap a
vs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ IntMap a -> [a]
forall a. IntMap a -> [a]
elems IntMap a
cs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [ a
x | FMType a
fmt <- FMType (FMType a) -> [FMType a]
forall a. FMType a -> [a]
eltsFMT FMType (FMType a)
as, a
x <- FMType a -> [a]
forall a. FMType a -> [a]
eltsFMT FMType a
fmt ] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [ a
x | FMType a
fmt <- FMType (FMType a) -> [FMType a]
forall a. FMType a -> [a]
eltsFMT FMType (FMType a)
fs, a
x <- FMType a -> [a]
forall a. FMType a -> [a]
eltsFMT FMType a
fmt ] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [ a
x | FMType a
fmt <- FMType (FMType a) -> [FMType a]
forall a. FMType a -> [a]
eltsFMT FMType (FMType a)
fus, a
x <- FMType a -> [a]
forall a. FMType a -> [a]
eltsFMT FMType a
fmt ]

{-
fmtToList :: FMType a -> [Typed a]
-- fmtToList = eltsFMT . mapFMT (\t a -> a:::t)
fmtToList EmptyFMT = []
fmtToList (FMT vs cs as fs fus) = fmToTypedVars vs ++ fmToTypedCons cs ++ [ x ::: TA t0 t1 | fmt:::t0 <- fmtToList as, x:::t1 <- fmtToList fmt ] ++ [ x ::: (t1 :> t0) | fmt:::t0 <- fmtToList fs, x:::t1 <- fmtToList fmt ] ++ [ x ::: (t1 :-> t0) | fmt:::t0 <- fmtToList fus, x:::t1 <- fmtToList fmt ]
fmToTypedVars fm = map (\ (tv,x) -> x ::: TV tv) (fmToList fm)
fmToTypedCons fm = map (\ (tc,x) -> x ::: TC tc) (fmToList fm)
-}
fmtToList :: FMType a -> [(Type,a)]
-- fmtToList = eltsFMT . mapFMT (\t a -> (t,a))
fmtToList :: FMType a -> [(Type, a)]
fmtToList FMType a
EmptyFMT = []
fmtToList (FMT IntMap a
vs IntMap a
cs FMType (FMType a)
as FMType (FMType a)
fs FMType (FMType a)
fus) = IntMap a -> [(Type, a)]
forall b. IntMap b -> [(Type, b)]
fmToTypedVars IntMap a
vs [(Type, a)] -> [(Type, a)] -> [(Type, a)]
forall a. [a] -> [a] -> [a]
++ IntMap a -> [(Type, a)]
forall b. IntMap b -> [(Type, b)]
fmToTypedCons IntMap a
cs [(Type, a)] -> [(Type, a)] -> [(Type, a)]
forall a. [a] -> [a] -> [a]
++ [ (Type -> Type -> Type
TA Type
t0 Type
t1, a
x) | (Type
t0, FMType a
fmt) <- FMType (FMType a) -> [(Type, FMType a)]
forall a. FMType a -> [(Type, a)]
fmtToList FMType (FMType a)
as, (Type
t1,a
x) <- FMType a -> [(Type, a)]
forall a. FMType a -> [(Type, a)]
fmtToList FMType a
fmt ] [(Type, a)] -> [(Type, a)] -> [(Type, a)]
forall a. [a] -> [a] -> [a]
++ [ (Type
t1 Type -> Type -> Type
:> Type
t0, a
x) | (Type
t0,FMType a
fmt) <- FMType (FMType a) -> [(Type, FMType a)]
forall a. FMType a -> [(Type, a)]
fmtToList FMType (FMType a)
fs, (Type
t1,a
x) <- FMType a -> [(Type, a)]
forall a. FMType a -> [(Type, a)]
fmtToList FMType a
fmt ] [(Type, a)] -> [(Type, a)] -> [(Type, a)]
forall a. [a] -> [a] -> [a]
++ [ (Type
t1 Type -> Type -> Type
:-> Type
t0, a
x) | (Type
t0,FMType a
fmt) <- FMType (FMType a) -> [(Type, FMType a)]
forall a. FMType a -> [(Type, a)]
fmtToList FMType (FMType a)
fus, (Type
t1,a
x) <- FMType a -> [(Type, a)]
forall a. FMType a -> [(Type, a)]
fmtToList FMType a
fmt ]
fmToTypedVars :: IntMap b -> [(Type, b)]
fmToTypedVars IntMap b
fm = ((Int, b) -> (Type, b)) -> [(Int, b)] -> [(Type, b)]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\ (Int
tv,b
x) -> (TyVar -> Type
TV (TyVar -> Type) -> TyVar -> Type
forall a b. (a -> b) -> a -> b
$ Int -> TyVar
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tv, b
x)) (IntMap b -> [(Int, b)]
forall a. IntMap a -> [(Int, a)]
toList IntMap b
fm)
fmToTypedCons :: IntMap b -> [(Type, b)]
fmToTypedCons IntMap b
fm = ((Int, b) -> (Type, b)) -> [(Int, b)] -> [(Type, b)]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\ (Int
tc,b
x) -> (TyVar -> Type
TC (TyVar -> Type) -> TyVar -> Type
forall a b. (a -> b) -> a -> b
$ Int -> TyVar
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tc, b
x)) (IntMap b -> [(Int, b)]
forall a. IntMap a -> [(Int, a)]
toList IntMap b
fm)

updateFMT :: (a->a) -> a -> Type -> (FMType a) -> FMType a
updateFMT :: (a -> a) -> a -> Type -> FMType a -> FMType a
updateFMT a -> a
f a
x Type
t FMType a
fmt = Type -> FMType a -> FMType a
updFMT Type
t FMType a
fmt
    where updFMT :: Type -> FMType a -> FMType a
updFMT Type
t      FMType a
EmptyFMT = Type -> FMType a -> FMType a
updFMT Type
t (IntMap a
-> IntMap a
-> FMType (FMType a)
-> FMType (FMType a)
-> FMType (FMType a)
-> FMType a
forall a.
IntMap a
-> IntMap a
-> FMType (FMType a)
-> FMType (FMType a)
-> FMType (FMType a)
-> FMType a
FMT IntMap a
forall a. IntMap a
empty IntMap a
forall a. IntMap a
empty FMType (FMType a)
forall a. FMType a
EmptyFMT FMType (FMType a)
forall a. FMType a
EmptyFMT FMType (FMType a)
forall a. FMType a
EmptyFMT)
          updFMT (TV TyVar
gen)    FMType a
fmt = FMType a
fmt{tvFMT :: IntMap a
tvFMT = (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
insertWith (\a
_new a
old -> a -> a
f a
old) (TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
gen) a
x (FMType a -> IntMap a
forall a. FMType a -> IntMap a
tvFMT FMType a
fmt)}
          updFMT (TC TyVar
con)    FMType a
fmt = FMType a
fmt{tcFMT :: IntMap a
tcFMT = (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
insertWith (\a
_new a
old -> a -> a
f a
old) (TyVar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral TyVar
con) a
x (FMType a -> IntMap a
forall a. FMType a -> IntMap a
tcFMT FMType a
fmt)}
          updFMT (TA Type
t0 Type
t1)  FMType a
fmt = FMType a
fmt{taFMT :: FMType (FMType a)
taFMT  = (FMType a -> FMType a)
-> FMType a -> Type -> FMType (FMType a) -> FMType (FMType a)
forall a. (a -> a) -> a -> Type -> FMType a -> FMType a
updateFMT FMType a -> FMType a
updFMTt1 (FMType a -> FMType a
updFMTt1 FMType a
forall a. FMType a
EmptyFMT) Type
t0 (FMType a -> FMType (FMType a)
forall a. FMType a -> FMType (FMType a)
taFMT FMType a
fmt)}
              where updFMTt1 :: FMType a -> FMType a
updFMTt1 = Type -> FMType a -> FMType a
updFMT Type
t1
          updFMT (Type
t0 :> Type
t1)  FMType a
fmt = FMType a
fmt{fnFMT :: FMType (FMType a)
fnFMT  = (FMType a -> FMType a)
-> FMType a -> Type -> FMType (FMType a) -> FMType (FMType a)
forall a. (a -> a) -> a -> Type -> FMType a -> FMType a
updateFMT FMType a -> FMType a
updFMTt0 (FMType a -> FMType a
updFMTt0 FMType a
forall a. FMType a
EmptyFMT) Type
t1 (FMType a -> FMType (FMType a)
forall a. FMType a -> FMType (FMType a)
fnFMT FMType a
fmt)}
              where updFMTt0 :: FMType a -> FMType a
updFMTt0 = Type -> FMType a -> FMType a
updFMT Type
t0
          updFMT (Type
t0 :-> Type
t1) FMType a
fmt = FMType a
fmt{funFMT :: FMType (FMType a)
funFMT = (FMType a -> FMType a)
-> FMType a -> Type -> FMType (FMType a) -> FMType (FMType a)
forall a. (a -> a) -> a -> Type -> FMType a -> FMType a
updateFMT FMType a -> FMType a
updFMTt0 (FMType a -> FMType a
updFMTt0 FMType a
forall a. FMType a
EmptyFMT) Type
t1 (FMType a -> FMType (FMType a)
forall a. FMType a -> FMType (FMType a)
funFMT FMType a
fmt)}
              where updFMTt0 :: FMType a -> FMType a
updFMTt0 = Type -> FMType a -> FMType a
updFMT Type
t0

unitFMT :: a -> Type -> FMType a
unitFMT a
x Type
t = (a -> a) -> a -> Type -> FMType a -> FMType a
forall a. (a -> a) -> a -> Type -> FMType a -> FMType a
updateFMT a -> a
forall a. HasCallStack => a
undefined a
x Type
t FMType a
forall a. FMType a
EmptyFMT
-- used by FMSubst.lhs

#ifdef SEMIGROUP
instance Semigroup a => Semigroup (FMType a) where
    <> :: FMType a -> FMType a -> FMType a
(<>) = (a -> a -> a) -> FMType a -> FMType a -> FMType a
forall a. (a -> a -> a) -> FMType a -> FMType a -> FMType a
unionFMT a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)
#endif
instance Monoid a => Monoid (FMType a) where
    mappend :: FMType a -> FMType a -> FMType a
mappend = (a -> a -> a) -> FMType a -> FMType a -> FMType a
forall a. (a -> a -> a) -> FMType a -> FMType a -> FMType a
unionFMT a -> a -> a
forall a. Monoid a => a -> a -> a
mappend
    mempty :: FMType a
mempty  = FMType a
forall a. FMType a
EmptyFMT

-- unionFMT is used by TypedTries.
unionFMT :: (a->a->a) -> FMType a -> FMType a -> FMType a
unionFMT :: (a -> a -> a) -> FMType a -> FMType a -> FMType a
unionFMT a -> a -> a
f FMType a
l FMType a
r = FMType a -> FMType a -> FMType a
uFMT FMType a
l FMType a
r
    where uFMT :: FMType a -> FMType a -> FMType a
uFMT FMType a
EmptyFMT FMType a
fmt = FMType a
fmt
          uFMT FMType a
fmt FMType a
EmptyFMT = FMType a
fmt
          uFMT (FMT IntMap a
vl IntMap a
cl FMType (FMType a)
al FMType (FMType a)
nl FMType (FMType a)
ul) (FMT IntMap a
vr IntMap a
cr FMType (FMType a)
ar FMType (FMType a)
nr FMType (FMType a)
ur) = IntMap a
-> IntMap a
-> FMType (FMType a)
-> FMType (FMType a)
-> FMType (FMType a)
-> FMType a
forall a.
IntMap a
-> IntMap a
-> FMType (FMType a)
-> FMType (FMType a)
-> FMType (FMType a)
-> FMType a
FMT ((a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
unionWith a -> a -> a
f IntMap a
vl IntMap a
vr) ((a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
unionWith a -> a -> a
f IntMap a
cl IntMap a
cr) ((FMType a -> FMType a -> FMType a)
-> FMType (FMType a) -> FMType (FMType a) -> FMType (FMType a)
forall a. (a -> a -> a) -> FMType a -> FMType a -> FMType a
unionFMT FMType a -> FMType a -> FMType a
uFMT FMType (FMType a)
al FMType (FMType a)
ar) ((FMType a -> FMType a -> FMType a)
-> FMType (FMType a) -> FMType (FMType a) -> FMType (FMType a)
forall a. (a -> a -> a) -> FMType a -> FMType a -> FMType a
unionFMT FMType a -> FMType a -> FMType a
uFMT FMType (FMType a)
nl FMType (FMType a)
nr) ((FMType a -> FMType a -> FMType a)
-> FMType (FMType a) -> FMType (FMType a) -> FMType (FMType a)
forall a. (a -> a -> a) -> FMType a -> FMType a -> FMType a
unionFMT FMType a -> FMType a -> FMType a
uFMT FMType (FMType a)
ul FMType (FMType a)
ur)
{-
unionFMT :: (forall a. a->a->a) -> FMType b -> FMType b -> FMType b
unionFMT f EmptyFMT fmt = fmt
unionFMT f fmt EmptyFMT = fmt
unionFMT f (FMT vl cl al nl ul) (FMT vr cr ar nr ur) = FMT (plusFM_C f vl vr) (plusFM_C f cl cr) (unionFMT (unionFMT f) al ar) (unionFMT (unionFMT f) nl nr) (unionFMT (unionFMT f) ul ur)
-}


\end{code}