forked from purescript/purescript
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathUnify.hs
More file actions
159 lines (134 loc) · 4.29 KB
/
Unify.hs
File metadata and controls
159 lines (134 loc) · 4.29 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
-----------------------------------------------------------------------------
--
-- Module : Control.Monad.Unify
-- Copyright : (c) Phil Freeman 2013
-- License : MIT
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
-- Portability :
--
-- |
--
--
-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Unify where
import Data.Monoid
import Control.Applicative
import Control.Monad.State
import Control.Monad.Error.Class (MonadError(..))
import Data.HashMap.Strict as M
-- |
-- Untyped unification variables
--
type Unknown = Int
-- |
-- A type which can contain unification variables
--
class Partial t where
unknown :: Unknown -> t
isUnknown :: t -> Maybe Unknown
unknowns :: t -> [Unknown]
($?) :: Substitution t -> t -> t
-- |
-- Identifies types which support unification
--
class (Partial t) => Unifiable m t | t -> m where
(=?=) :: t -> t -> UnifyT t m ()
-- |
-- A substitution maintains a mapping from unification variables to their values
--
data Substitution t = Substitution { runSubstitution :: M.HashMap Int t }
instance (Partial t) => Monoid (Substitution t) where
mempty = Substitution M.empty
s1 `mappend` s2 = Substitution $
M.map (s2 $?) (runSubstitution s1) `M.union`
M.map (s1 $?) (runSubstitution s2)
-- |
-- State required for type checking
--
data UnifyState t = UnifyState {
-- |
-- The next fresh unification variable
--
unifyNextVar :: Int
-- |
-- The current substitution
--
, unifyCurrentSubstitution :: Substitution t
}
-- |
-- An empty @UnifyState@
--
defaultUnifyState :: (Partial t) => UnifyState t
defaultUnifyState = UnifyState 0 mempty
-- |
-- A class for errors which support unification errors
--
class UnificationError t e where
occursCheckFailed :: t -> e
-- |
-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
--
newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }
deriving (Functor, Monad, Applicative, Alternative, MonadPlus)
instance (MonadState s m) => MonadState s (UnifyT t m) where
get = UnifyT . lift $ get
put = UnifyT . lift . put
instance (MonadError e m) => MonadError e (UnifyT t m) where
throwError = UnifyT . throwError
catchError e f = UnifyT $ catchError (unUnify e) (unUnify . f)
-- |
-- Run a computation in the Unify monad, failing with an error, or succeeding with a return value and the new next unification variable
--
runUnify :: UnifyState t -> UnifyT t m a -> m (a, UnifyState t)
runUnify s = flip runStateT s . unUnify
-- |
-- Substitute a single unification variable
--
substituteOne :: (Partial t) => Unknown -> t -> Substitution t
substituteOne u t = Substitution $ M.singleton u t
-- |
-- Replace a unification variable with the specified value in the current substitution
--
(=:=) :: (UnificationError t e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()
(=:=) u t' = do
st <- UnifyT get
let sub = unifyCurrentSubstitution st
let t = sub $? t'
occursCheck u t
let current = sub $? unknown u
case isUnknown current of
Just u1 | u1 == u -> return ()
_ -> current =?= t
UnifyT $ modify $ \s -> s { unifyCurrentSubstitution = substituteOne u t <> unifyCurrentSubstitution s }
-- |
-- Perform the occurs check, to make sure a unification variable does not occur inside a value
--
occursCheck :: (UnificationError t e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()
occursCheck u t =
case isUnknown t of
Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ occursCheckFailed t
_ -> return ()
-- |
-- Generate a fresh untyped unification variable
--
fresh' :: (Monad m) => UnifyT t m Unknown
fresh' = do
st <- UnifyT get
UnifyT $ modify $ \s -> s { unifyNextVar = succ (unifyNextVar s) }
return $ unifyNextVar st
-- |
-- Generate a fresh unification variable at a specific type
--
fresh :: (Monad m, Partial t) => UnifyT t m t
fresh = do
u <- fresh'
return $ unknown u