git.iko.soy/rowtype-yoga/purescript-native
on 69c028d help sign in
rowtype-yoga/purescript-native/src/PureScript/TypeChecker/Synonyms.hs
58 lines 2.0 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : PureScript.TypeChecker.Synonyms
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15{-# LANGUAGE Rank2Types #-}
17module PureScript.TypeChecker.Synonyms (
18 substituteTypeSynonym
19) where
21import PureScript.Types
22import PureScript.Declarations
24import Data.Maybe (fromMaybe)
25import Data.Data
26import Data.Generics
27import Control.Arrow
28import Control.Monad.Writer
29import Control.Monad.Error
30import qualified Data.Map as M
32replaceTypeVars :: M.Map String Type -> Type -> Type
33replaceTypeVars m = everywhere (mkT replace)
34 where
35 replace :: Type -> Type
36 replace t@(TypeVar var) = fromMaybe t (M.lookup var m)
37 replace t = t
39buildTypeSubstitution :: String -> Type -> [String] -> Type -> WriterT Any (Either String) (Maybe Type)
40buildTypeSubstitution name ty args = go (reverse args) M.empty
41 where
42 go :: [String] -> M.Map String Type -> Type -> WriterT Any (Either String) (Maybe Type)
43 go [] m (TypeConstructor ctor) | name == ctor = tell (Any True) >> return (Just $ replaceTypeVars m ty)
44 go (_:_) _ (TypeConstructor ctor) | name == ctor = lift . throwError $ "Partially applied type synonym " ++ name
45 go (arg:args) m (TypeApp f x) = go args (M.insert arg x m) f
46 go _ _ _ = return Nothing
48everywhereButM' :: (Monad m, Data d) => (forall d. (Data d) => d -> WriterT Any m d) -> d -> m d
49everywhereButM' f x = do
50 (y, halt) <- runWriterT $ f x
51 case getAny halt of
52 True -> return y
53 _ -> gmapM (everywhereButM' f) y
55substituteTypeSynonym :: String -> [String] -> Type -> Type -> Either String Type
56substituteTypeSynonym name args ty = everywhereButM' (mkM replace)
57 where
58 replace t = fmap (fromMaybe t) $ buildTypeSubstitution name ty args t