module Language.PureScript.Types where
import Data.Data
import Data.List (nub)
import Data.Generics (everything, mkQ)
import Control.Monad.Unify
import Control.Arrow (second)
import Language.PureScript.Names
newtype SkolemScope = SkolemScope { runSkolemScope :: Int } deriving (Show, Eq, Ord, Data, Typeable)
data Type
= TUnknown Unknown
| Object Type
| TypeVar String
| TypeConstructor (Qualified ProperName)
| TypeApp Type Type
| SaturatedTypeSynonym (Qualified ProperName) [Type]
| ForAll String Type (Maybe SkolemScope)
| ConstrainedType [(Qualified ProperName, [Type])] Type
| Skolem Int SkolemScope
| REmpty
| RCons String Type Type
| PrettyPrintFunction Type Type
| PrettyPrintArray Type deriving (Show, Eq, Data, Typeable)
tyFunction :: Type
tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")
tyString :: Type
tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")
tyNumber :: Type
tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")
tyBoolean :: Type
tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")
tyArray :: Type
tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
function :: Type -> Type -> Type
function t1 = TypeApp (TypeApp tyFunction t1)
rowToList :: Type -> ([(String, Type)], Type)
rowToList (RCons name ty row) = let (tys, rest) = rowToList row
in ((name, ty):tys, rest)
rowToList r = ([], r)
rowFromList :: ([(String, Type)], Type) -> Type
rowFromList ([], r) = r
rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
isMonoType :: Type -> Bool
isMonoType ForAll{} = False
isMonoType _ = True
mkForAll :: [String] -> Type -> Type
mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args
unit :: Type
unit = Object REmpty
replaceTypeVars :: String -> Type -> Type -> Type
replaceTypeVars = replaceTypeVars' []
where
replaceTypeVars' bound name replacement = go bound
where
go :: [String] -> Type -> Type
go bs (Object r) = Object $ go bs r
go _ (TypeVar v) | v == name = replacement
go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)
go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts
go bs f@(ForAll v t sco) | v == name = f
| v `elem` usedTypeVariables replacement =
let v' = genName v (name : bs ++ usedTypeVariables replacement)
t' = replaceTypeVars' bs v (TypeVar v') t
in ForAll v' (go (v' : bs) t') sco
| otherwise = ForAll v (go (v : bs) t) sco
go bs (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs)) cs) (go bs t)
go bs (RCons name' t r) = RCons name' (go bs t) (go bs r)
go _ ty = ty
genName orig inUse = try 0
where
try n | (orig ++ show n) `elem` inUse = try (n + 1)
| otherwise = orig ++ show n
replaceAllTypeVars :: [(String, Type)] -> Type -> Type
replaceAllTypeVars = foldl (\f (name, ty) -> replaceTypeVars name ty . f) id
usedTypeVariables :: Type -> [String]
usedTypeVariables = nub . everything (++) (mkQ [] go)
where
go (TypeVar v) = [v]
go _ = []
freeTypeVariables :: Type -> [String]
freeTypeVariables = nub . go []
where
go :: [String] -> Type -> [String]
go bound (Object r) = go bound r
go bound (TypeVar v) | v `notElem` bound = [v]
go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
go bound (ForAll v t _) = go (v : bound) t
go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t
go bound (RCons _ t r) = go bound t ++ go bound r
go _ _ = []
quantify :: Type -> Type
quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty