module CSPM.DataStructures.Types (
TypeVar, TypeScheme(..), Constraint(..), Type(..), TypeVarRef(..),
prettyPrintTypes, isRigid, constraintImpliedBy, reduceConstraints,
collectConstraints,
freshTypeVar, freshTypeVarWithConstraints, freshTypeVarRef,
freshRigidTypeVarWithConstraints,
SymbolTable, PSymbolTable, freshPSymbolTable, readPSymbolTable,
setPSymbolTable,
PType, freshPType, readPType, setPType,
) where
import Control.Monad.Reader
import Data.IORef
import Data.List
import qualified Data.Map as Mp
import Data.Supply
import System.IO.Unsafe
import CSPM.DataStructures.Names
import qualified Util.MonadicPrettyPrint as M
import Util.Exception
import Util.PartialFunctions
import Util.Precedence
import Util.Prelude
import Util.PrettyPrint
newtype TypeVar = TypeVar Int deriving (Eq, Ord, Show)
instance PrettyPrintable TypeVar where
prettyPrint (TypeVar x) = int x
data TypeScheme =
ForAll {
typeSchemeVariables :: [(TypeVar, [Constraint])],
typeSchemeType :: Type
}
deriving (Eq, Show)
data Constraint =
CEq
| COrd
| CInputable
| CSet
| CYieldable
deriving (Eq, Ord, Show)
constraintImpliedBy :: Constraint -> Constraint -> Bool
constraintImpliedBy c1 c2 | c1 == c2 = True
constraintImpliedBy CSet CEq = True
constraintImpliedBy _ _ = False
reduceConstraints :: [Constraint] -> [Constraint]
reduceConstraints cs =
case [c | c <- cs, c' <- cs, c /= c', constraintImpliedBy c c'] of
[] -> cs
(c:_) -> reduceConstraints (cs \\ [c])
data Type =
TVar TypeVarRef
| TProc
| TInt
| TBool
| TChar
| TEvent
| TExtendable {
extendableUltimateType :: Type,
extendableArgument :: TypeVarRef
}
| TExtendableEmptyDotList
| TSet Type
| TSeq Type
| TDot Type Type
| TMap {
mapKeyType :: Type,
mapValueType :: Type
}
| TTuple [Type]
| TFunction [Type] Type
| TDotable Type Type
| TDatatype Name
deriving (Eq, Ord, Show)
data TypeVarRef =
TypeVarRef {
typeVar :: TypeVar,
constraints :: [Constraint],
typePointer :: PType
}
| RigidTypeVarRef {
typeVar :: TypeVar,
constraints :: [Constraint],
rigidName :: Name
}
instance Eq TypeVarRef where
tvref1 == tvref2 = typeVar tvref1 == typeVar tvref2
instance Ord TypeVarRef where
compare tvref1 tvref2 = compare (typeVar tvref1) (typeVar tvref2)
instance Show TypeVarRef where
show (TypeVarRef tv cs _) = "TypeVarRef "++show tv++" "++show cs
show (RigidTypeVarRef tv cs n) =
"RigidTypeVarRef "++show tv ++" "++show cs++" "++show n
isRigid :: TypeVarRef -> Bool
isRigid (RigidTypeVarRef _ _ _) = True
isRigid _ = False
typeVarSupply :: IORef (Supply Int)
typeVarSupply = unsafePerformIO (do
s <- newNumSupply
newIORef s)
takeTypeVarFromSupply :: MonadIO m => m TypeVar
takeTypeVarFromSupply = do
s <- liftIO $ atomicModifyIORef typeVarSupply split2
return $ TypeVar $ supplyValue s
freshTypeVar :: MonadIO m => m Type
freshTypeVar = freshTypeVarWithConstraints []
freshTypeVarRef :: MonadIO m => [Constraint] -> m TypeVarRef
freshTypeVarRef cs = do
tv <- takeTypeVarFromSupply
ioRef <- freshPType
return $ TypeVarRef tv cs ioRef
freshTypeVarWithConstraints :: MonadIO m => [Constraint] -> m Type
freshTypeVarWithConstraints cs = freshTypeVarRef cs >>= return . TVar
freshRigidTypeVarWithConstraints :: MonadIO m => Name -> [Constraint] -> m Type
freshRigidTypeVarWithConstraints n cs = do
tv <- takeTypeVarFromSupply
return $ TVar (RigidTypeVarRef tv cs n)
type SymbolTable = PartialFunction Name TypeScheme
type PType = IORef (Maybe Type)
type PSymbolTable = IORef SymbolTable
readPType :: (MonadIO m) => PType -> m (Maybe Type)
readPType ioref = liftIO $ readIORef ioref
setPType :: (MonadIO m) => PType -> Type -> m ()
setPType ioref t = liftIO $ writeIORef ioref (Just t)
freshPType :: (MonadIO m) => m PType
freshPType = liftIO $ newIORef Nothing
readPSymbolTable :: (MonadIO m) => PSymbolTable -> m SymbolTable
readPSymbolTable ioref = liftIO $ readIORef ioref
setPSymbolTable :: (MonadIO m) => PSymbolTable -> SymbolTable -> m ()
setPSymbolTable ioref t = liftIO $ writeIORef ioref t
freshPSymbolTable :: (MonadIO m) => m PSymbolTable
freshPSymbolTable = liftIO $ newIORef []
instance PrettyPrintable Constraint where
prettyPrint CEq = text "Eq"
prettyPrint COrd = text "Ord"
prettyPrint CInputable = text "Inputable"
prettyPrint CSet = text "Set"
prettyPrint CYieldable = text "Yieldable"
prettyPrintTypes :: [Type] -> [Doc]
prettyPrintTypes ts = map (flip runReader vmap . M.prettyPrint) ts
where
vs = (nub . map fst . concatMap collectConstraints) ts
tvrefs = map
vmap = variableMapForTypeVars vs
type VarMap = Mp.Map TypeVar Doc
variableMapForTypeVars :: [TypeVarRef] -> VarMap
variableMapForTypeVars tvs =
let
(rigid, nonRigid) = partition isRigid tvs
extract (RigidTypeVarRef _ _ n) = [show n]
usedCharacterStrings = concatMap extract rigid
gen :: Int -> [Char] -> [Char] -> [Doc]
gen n xs [] = gen (n+1) xs xs
gen 1 xs (y:ys) = char y : gen 1 xs ys
gen n xs (y:ys) = text (y:show (n1)) : gen n xs ys
notUsed xs = not (show xs `elem` usedCharacterStrings)
initialGen = if length rigid > 0 then 1 else 0
availableStrings = filter notUsed (gen initialGen ['a'..'z'] [])
vs = map (\ (RigidTypeVarRef tv _ n) -> (tv, prettyPrint n)) rigid
++ zip (map typeVar nonRigid) availableStrings
in Mp.fromList vs
instance PrettyPrintable Type where
prettyPrint t = prettyPrint (ForAll ts t)
where ts = [(typeVar tv, cs) | (tv, cs) <- collectConstraints t]
instance Precedence Type where
precedence (TDotable _ _) = 2
precedence (TExtendable _ _) = 2
precedence (TDot _ _) = 1
precedence (TMap _ _) = 1
precedence (TVar _) = 0
precedence (TFunction _ _) = 0
precedence (TSeq _) = 0
precedence (TSet _) = 0
precedence (TTuple _) = 0
precedence (TDatatype _) = 0
precedence TBool = 0
precedence TInt = 0
precedence TProc = 0
precedence TEvent = 0
precedence TChar = 0
associativity (TDotable _ _) = AssocRight
associativity (TExtendable _ _) = AssocRight
associativity (TDot _ _) = AssocLeft
associativity _ = AssocNone
sameOperator (TDotable _ _) (TDotable _ _) = True
sameOperator (TExtendable _ _) (TExtendable _ _) = True
sameOperator (TDot _ _) (TDot _ _) = True
sameOperator (TMap _ _) (TMap _ _) = True
sameOperator (TVar _) (TVar _) = True
sameOperator (TFunction _ _) (TFunction _ _) = True
sameOperator (TSeq _) (TSeq _) = True
sameOperator (TSet _) (TSet _) = True
sameOperator (TTuple _) (TTuple _) = True
sameOperator (TDatatype _) (TDatatype _) = True
sameOperator TBool TBool = True
sameOperator TInt TInt = True
sameOperator TProc TProc = True
sameOperator TEvent TEvent = True
sameOperator TChar TChar = True
sameOperator _ _ = False
instance M.MonadicPrettyPrintable (Reader VarMap) Type where
prettyPrint (TVar tvref) = do
st <- ask
return $! case Mp.lookup (typeVar tvref) st of
Just c -> c
Nothing -> prettyPrint (typeVar tvref)
prettyPrint (TFunction targs tr) =
M.parens (M.list (mapM M.prettyPrint targs))
M.<+> M.text "->" M.<+> M.prettyPrint tr
prettyPrint (TSeq t) =
M.char '<' M.<> M.prettyPrint t M.<> M.char '>'
prettyPrint (TSet t) =
M.braces (M.prettyPrint t)
prettyPrint (TTuple ts) =
M.parens (M.list (mapM M.prettyPrint ts))
prettyPrint (TMap k v) =
M.text "Map" M.<+> M.prettyPrint k M.<+> M.prettyPrint v
prettyPrint (op@(TDot t1 t2)) =
M.ppBinaryOp' op (M.char '.') t1 t2
prettyPrint (op@(TDotable t1 t2)) = M.ppBinaryOp' op (M.text "=>") t1 t2
prettyPrint (TDatatype n) = M.prettyPrint n
prettyPrint TBool = M.text "Bool"
prettyPrint TInt = M.text "Int"
prettyPrint TProc = M.text "Proc"
prettyPrint TEvent = M.text "Event"
prettyPrint TChar = M.text "Char"
prettyPrint (op@(TExtendable t tvref)) =
M.ppBinaryOp' op (M.text "=>*") (TVar tvref) t
instance PrettyPrintable TypeScheme where
prettyPrint (ForAll ts t) =
case varsWithCs of
[] -> empty
[x] -> constraintsText <+> text "=> "
_ -> parens constraintsText <+> text "=> "
<> runReader (M.prettyPrint t) vmap
where
vmap = variableMapForTypeVars (map fst (collectConstraints t))
varsWithCs = [(v, c) | (v, cs) <- nub (sortConstraints ts),
c <- reduceConstraints cs, cs /= []]
compareConstraints (tv1, cs1) (tv2, cs2) =
compare (show $ Mp.lookup tv1 vmap) (show $ Mp.lookup tv2 vmap)
`thenCmp` compare cs1 cs2
sortConstraints = sortBy compareConstraints
constraintsText = list [
prettyPrint c <+>
case Mp.lookup tv vmap of
Just x -> x
Nothing -> panic "Could not pretty print type"
| (tv, c) <- varsWithCs]
collectConstraints :: Type -> [(TypeVarRef, [Constraint])]
collectConstraints = combine . collect
where
combine :: [(TypeVarRef, [Constraint])] -> [(TypeVarRef, [Constraint])]
combine xs =
map (\ ys -> (head (map fst ys), nub (concat (map snd ys))))
(groupBy (\ (v1, _) (v2, _) -> v1 == v2) xs)
collect :: Type -> [(TypeVarRef, [Constraint])]
collect (TVar tvref) = [(tvref, constraints tvref)]
collect (TFunction targs tr) =
concatMap collect targs ++ collect tr
collect (TSeq t) = collect t
collect (TSet t) = collect t
collect (TTuple ts) = concatMap collect ts
collect (TDot t1 t2) = collect t1 ++ collect t2
collect (TDotable t1 t2) = collect t1 ++ collect t2
collect (TMap k v) = collect k ++ collect v
collect (TDatatype _) = []
collect TBool = []
collect TInt = []
collect TProc = []
collect TEvent = []
collect TChar = []
collect (TExtendable t tvref) =
(tvref, constraints tvref) : collect t