module Language.PureScript.Types where
import Data.Data
import Data.List (nub)
import Data.Generics (everything, mkT, mkQ, everywhereBut)
import Control.Monad.Unify
import Control.Arrow ((***))
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 t2 = TypeApp (TypeApp tyFunction t1) t2
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 ty = 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 bs (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 (id *** 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
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 (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