suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Changed TypeExp to stop using Data.Generics (which was getting awkward)

Browse Source 
Instead of storing the Constr, which was messy, we now store a String (to allow comparison of constructor types during unification) and a function to reform the type at the end of the type checking.
This commit is contained in:
Neil Brown 2008-05-17 19:44:45 +00:00
parent abbca5f235
commit 1115364d47
3 changed files with 45 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
frontends/RainTypes.hs
View File

@ -49,8 +49,8 @@ lookupMapElseMutVar k
put st {csUnifyLookup = m'}
return v
ttte :: Data b => b -> A.Type -> PassM (TypeExp A.Type)
ttte c t = typeToTypeExp t >>= \t' -> return $ OperType (toConstr c) [t']
ttte :: String -> (A.Type -> A.Type) -> A.Type -> PassM (TypeExp A.Type)
ttte c f t = typeToTypeExp t >>= \t' -> return $ OperType c (\[x] -> f x) [t']
-- Transforms the given type into a typeexp, such that the only inner types
-- left will be the primitive types (integer types, float types, bool, time). Arrays
@ -58,11 +58,11 @@ ttte c t = typeToTypeExp t >>= \t' -> return $ OperType (toConstr c) [t']
-- neither are records.
-- User data types should not be present in the input.
typeToTypeExp :: A.Type -> PassM (TypeExp A.Type)
typeToTypeExp x@(A.List t) = ttte x t
typeToTypeExp (A.Chan A.DirInput _ t) = ttte "?" t
typeToTypeExp (A.Chan A.DirOutput _ t) = ttte "!" t
typeToTypeExp (A.Chan A.DirUnknown _ t) = ttte "channel" t
typeToTypeExp (A.Mobile t) = ttte "MOBILE" t
typeToTypeExp (A.List t) = ttte "[]" A.List t
typeToTypeExp (A.Chan A.DirInput at t) = ttte "?" (A.Chan A.DirInput at) t
typeToTypeExp (A.Chan A.DirOutput at t) = ttte "!" (A.Chan A.DirOutput at) t
typeToTypeExp (A.Chan A.DirUnknown at t) = ttte "channel" (A.Chan A.DirUnknown at) t
typeToTypeExp (A.Mobile t) = ttte "MOBILE" A.Mobile t
typeToTypeExp (A.UnknownVarType en)
= case en of
Left n -> lookupMapElseMutVar (UnifyIndex (A.nameMeta n, Right n))
@ -73,8 +73,8 @@ typeToTypeExp (A.UnknownNumLitType m id n)
st <- get
let mp = csUnifyLookup st
put st {csUnifyLookup = Map.insert (UnifyIndex (m,Left id)) v mp}
return v
typeToTypeExp t = return $ OperType (toConstr t) []
return v
typeToTypeExp t = return $ OperType (show t) (const t) []
markUnify :: (Typed a, Typed b) => a -> b -> PassM ()
markUnify x y

59
frontends/TypeUnification.hs
View File

@ -19,23 +19,25 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
module TypeUnification where
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Data.Generics
import qualified Data.Map as Map
import Data.Maybe
import Data.IORef
import qualified AST as A
import Errors
import Metadata
import Pass
import ShowCode
import UnifyType
import Utils
foldCon :: Constr -> [Either String A.Type] -> Either String A.Type
foldCon con [] = Right $ fromConstr con
foldCon con [Left e] = Left e
foldCon con [Right t] = Right $ fromConstrB (fromJust $ cast t) con
foldCon con _ = Left "foldCon: too many arguments given"
foldCon :: ([A.Type] -> A.Type) -> [Either String A.Type] -> Either String A.Type
foldCon con es = case splitEither es of
([],ts) -> Right $ con ts
((e:_),_) -> Left e
-- Much of the code in this module is taken from or based on Tim Sheard's Haskell
-- listing of a simple type unification algorithm at the beginning of his
@ -65,8 +67,8 @@ unifyRainTypes m' prs
[] -> return $ Right mapOfRes
where
read :: k -> TypeExp A.Type -> IO (Either String A.Type)
read k (OperType con vals) = do vals' <- mapM (read k) vals
return $ foldCon con vals'
read k (OperType _ con vals) = do vals' <- mapM (read k) vals
return $ foldCon con vals'
read k (MutVar v) = readIORef v >>= \t -> case t of
Nothing -> return $ Left $ "Type error in unification, "
++ "ambigious type remains for: " ++ show k
@ -76,16 +78,23 @@ unifyRainTypes m' prs
++ "ambigious type remains for numeric literal: " ++ show k
Right t -> return $ Right t
fromTypeExp :: Meta -> TypeExp A.Type -> PassM A.Type
fromTypeExp m x = fromTypeExp' =<< (liftIO $ prune x)
where
fromTypeExp' :: TypeExp A.Type -> PassM A.Type
fromTypeExp' (MutVar {}) = dieP m "Unresolved type"
fromTypeExp' (GenVar {}) = dieP m "Template vars not yet supported"
fromTypeExp' (NumLit v) = liftIO (readIORef v) >>= \x -> case x of
Left (n:_) -> dieP m $ "Ambigiously typed numeric literal: " ++ show n
Right t -> return t
fromTypeExp' (OperType _ f ts) = mapM (fromTypeExp m) ts >>* f
-- For debugging:
showInErr :: TypeExp A.Type -> PassM String
showInErr (MutVar {}) = return "MutVar"
showInErr (GenVar {}) = return "GenVar"
showInErr (NumLit {}) = return "NumLit"
showInErr (OperType c ts) = showCode $ case length ts of
0 -> fromConstr c :: A.Type
1 -> (fromConstr c :: A.Type -> A.Type)
(A.UserDataType $ A.Name {A.nameName = "a"})
:: A.Type
showInErr t@(OperType {}) = showCode =<< fromTypeExp undefined t
giveErr :: String -> TypeExp A.Type -> TypeExp A.Type -> Either (PassM String) a
giveErr msg tx ty
@ -93,7 +102,7 @@ giveErr msg tx ty
y <- showInErr ty
return $ msg ++ x ++ " and " ++ y
prune :: TypeExp a -> IO (TypeExp a)
prune :: Typeable a => TypeExp a -> IO (TypeExp a)
prune t =
case t of
MutVar r ->
@ -106,15 +115,13 @@ prune t =
return t'
_ -> return t
occursInType :: Ptr a -> TypeExp a -> IO Bool
occursInType :: Typeable a => Ptr a -> TypeExp a -> IO Bool
occursInType r t =
do t' <- prune t
case t' of
MutVar r2 -> return $ r == r2
GenVar n -> return False
OperType nm ts ->
do bs <- mapM (occursInType r) ts
return (or bs)
OperType _ _ ts -> mapM (occursInType r) ts >>* or
unifyType :: TypeExp A.Type -> TypeExp A.Type -> IO (Either (PassM String) ())
unifyType te1 te2
@ -133,7 +140,7 @@ unifyType te1 te2
(_,MutVar _) -> unifyType t2' t1'
(GenVar n,GenVar m) ->
if n == m then return $ Right () else return $ Left $ return "different genvars"
(OperType n1 ts1,OperType n2 ts2) ->
(OperType n1 _ ts1,OperType n2 _ ts2) ->
if n1 == n2
then unifyArgs ts1 ts2
else return $ giveErr "Different constructors: " t1' t2'
@ -147,7 +154,7 @@ unifyType te1 te2
else return $ Right ()
(Left ns1, Left ns2) ->
do writeIORef vns1 $ Left (ns1 ++ ns2)
writeIORef vns2 $ Left (ns1 ++ ns2)
writeIORef vns2 $ Left (ns2 ++ ns1)
return $ Right ()
(Right {}, Left {}) -> unifyType t2' t1'
(Left ns1, Right t2) ->
@ -156,18 +163,18 @@ unifyType te1 te2
return $ Right ()
else return $ Left $ return "Numeric literals will not fit in concrete type"
(OperType {}, NumLit {}) -> unifyType t2' t1'
(NumLit vns1, OperType n1 ts2) ->
(NumLit vns1, OperType n1 f ts2) ->
do nst1 <- readIORef vns1
case nst1 of
Right t ->
if null ts2 && t == fromConstr n1
if null ts2 && t == f []
then return $ Right ()
else return $ Left $ return $ "numeric literal cannot be unified"
++ " with two different types"
Left ns ->
if null ts2
then if all (willFit $ fromConstr n1) ns
then do writeIORef vns1 $ Right (fromConstr n1)
then if all (willFit $ f []) ns
then do writeIORef vns1 $ Right (f [])
return $ Right ()
else return $ Left $ return "Numeric literals will not fit in concrete type"
else return $ Left $ return $ "Numeric literal cannot be unified"
@ -181,10 +188,10 @@ unifyType te1 te2
unifyArgs [] [] = return $ Right ()
unifyArgs _ _ = return $ Left $ return "different lengths"
instantiate :: [TypeExp a] -> TypeExp a -> TypeExp a
instantiate :: Typeable a => [TypeExp a] -> TypeExp a -> TypeExp a
instantiate ts x = case x of
MutVar _ -> x
OperType nm xs -> OperType nm (map (instantiate ts) xs)
OperType nm f xs -> OperType nm f (map (instantiate ts) xs)
GenVar n -> ts !! n
willFit :: A.Type -> Integer -> Bool

42
frontends/UnifyType.hs
View File

@ -25,46 +25,10 @@ import qualified AST as A
type Ptr a = IORef (Maybe (TypeExp a))
data TypeExp a
data Typeable a => TypeExp a
= MutVar (Ptr a)
| GenVar Int
-- Either a list of integers that must fit, or a concrete type
| NumLit (IORef (Either [Integer] A.Type))
| OperType Constr [ TypeExp a ]
deriving (Typeable)
-- Because Constr is not a member of Data, we must provide our own Data instance
-- here:
_typeExp_MutVarConstr, _typeExp_GenVarConstr, _typeExp_NumLitConstr,
_typeExp_OperTypeConstr :: Constr
_typeExp_DataType :: DataType
_typeExp_MutVarConstr = mkConstr _typeExp_DataType "MutVar" [] Prefix
_typeExp_GenVarConstr = mkConstr _typeExp_DataType "GenVar" [] Prefix
_typeExp_NumLitConstr = mkConstr _typeExp_DataType "NumLit" [] Prefix
_typeExp_OperTypeConstr = mkConstr _typeExp_DataType "OperType" [] Prefix
_typeExp_DataType = mkDataType "TypeUnification.TypeExp"
[ _typeExp_MutVarConstr
, _typeExp_GenVarConstr
, _typeExp_NumLitConstr
, _typeExp_OperTypeConstr
]
instance Data a => Data (TypeExp a) where
gfoldl f z (MutVar x) = z MutVar `f` x
gfoldl f z (GenVar x) = z GenVar `f` x
gfoldl f z (NumLit x) = z NumLit `f` x
-- We leave the Constr item untouched, as it is not of type Data:
gfoldl f z (OperType x y) = z (OperType x) `f` y
toConstr (MutVar {}) = _typeExp_MutVarConstr
toConstr (GenVar {}) = _typeExp_GenVarConstr
toConstr (NumLit {}) = _typeExp_NumLitConstr
toConstr (OperType {}) = _typeExp_OperTypeConstr
gunfold k z c = case constrIndex c of
1 -> (k) (z MutVar)
2 -> (k) (z GenVar)
3 -> (k) (z NumLit)
4 -> error "gunfold typeExp OperType"
_ -> error "gunfold typeExp"
dataTypeOf _ = _typeExp_DataType
| OperType String ([A.Type] -> A.Type) [ TypeExp a ]
deriving (Typeable, Data)