@@ -2,7 +2,7 @@
22module Type.State
33 ( Solver
44 , run
5− , SolverState(..)
5+ , State(..)
66 , Pool(..)
77 , Env
88 , modifyEnv
@@ -21,7 +21,9 @@ module Type.State
2121 )
2222 where
2323
24−import qualified Control.Monad.State as State
24+
25+import Control.Monad (liftM2)
26+import Control.Monad.Trans (MonadIO, liftIO)
2527import qualified Data.Map as Map
2628import Data.Map ((!))
2729import Data.Text (Text)
@@ -33,29 +35,40 @@ import qualified Reporting.Region as R
3335import Type.Type
3436
3537
38+
3639-- SOLVER
3740
3841
39−type Solver = State.StateT SolverState IO
42+newtype Solver a =
43+ Solver { _solve :: State -> IO (a, State) }
44+
45+
46+
47+-- RUN SOLVER
4048
4149
42−run :: Solver () -> IO SolverState
43−run solver =
44− State.execStateT solver $
45− SS
46− { sEnv = Map.empty
47− , sSavedEnv = Map.empty
48− , sPool = Pool outermostRank []
49− , sMark = noMark + 1 -- The mark must never be equal to noMark!
50− , sError = []
51− }
50+run :: Solver () -> IO State
51+run (Solver solver) =
52+ do (_, state) <- solver initialState
53+ return state
54+
55+
56+initialState :: State
57+initialState =
58+ SS
59+ { sEnv = Map.empty
60+ , sSavedEnv = Map.empty
61+ , sPool = Pool outermostRank []
62+ , sMark = noMark + 1 -- The mark must never be equal to noMark!
63+ , sError = []
64+ }
5265
5366
5467
5568-- SOLVER STATE
5669
5770
58−data SolverState =
71+data State =
5972 SS
6073 { sEnv :: Env
6174 , sSavedEnv :: Env
@@ -71,8 +84,8 @@ The young pool exists to make it possible to identify these vars in constant tim
7184-}
7285data Pool =
7386 Pool
74− { maxRank :: Int
75− , inhabitants :: [Variable]
87+ { _maxRank :: Int
88+ , _inhabitants :: [Variable]
7689 }
7790
7891
@@ -83,67 +96,105 @@ type Env = Map.Map Text (A.Located Variable)
8396-- HELPERS
8497
8598
99+{-# INLINE modifyEnv #-}
86100modifyEnv :: (Env -> Env) -> Solver ()
87101modifyEnv f =
88− State.modify $ \state -> state { sEnv = f (sEnv state) }
102+ Solver $ \state ->
103+ return ( (), state { sEnv = f (sEnv state) } )
89104
90105
106+{-# INLINE modifyPool #-}
91107modifyPool :: (Pool -> Pool) -> Solver ()
92108modifyPool f =
93− State.modify $ \state -> state { sPool = f (sPool state) }
109+ Solver $ \state ->
110+ return ( (), state { sPool = f (sPool state) } )
94111
95112
113+{-# INLINE addError #-}
96114addError :: R.Region -> Error.Error -> Solver ()
97115addError region err =
98− State.modify $ \state -> state { sError = A.A region err : sError state }
116+ Solver $ \state ->
117+ return ( (), state { sError = A.A region err : sError state } )
99118
100119
120+{-# INLINE switchToPool #-}
101121switchToPool :: Pool -> Solver ()
102122switchToPool pool =
103− modifyPool (\_ -> pool)
123+ modifyPool (\_ -> pool)
104124
105125
126+{-# INLINE getPool #-}
106127getPool :: Solver Pool
107128getPool =
108− State.gets sPool
129+ Solver $ \state ->
130+ return ( sPool state, state )
109131
110132
133+{-# INLINE getEnv #-}
111134getEnv :: Solver Env
112135getEnv =
113− State.gets sEnv
136+ Solver $ \state ->
137+ return ( sEnv state, state )
114138
115139
140+{-# INLINE saveLocalEnv #-}
116141saveLocalEnv :: Solver ()
117142saveLocalEnv =
118− do currentEnv <- getEnv
119− State.modify $ \state -> state { sSavedEnv = currentEnv }
143+ Solver $ \state ->
144+ return ( (), state { sSavedEnv = sEnv state } )
120145
121146
147+{-# INLINE uniqueMark #-}
122148uniqueMark :: Solver Int
123149uniqueMark =
124− do state <- State.get
125− let mark = sMark state
126− State.put $ state { sMark = mark + 1 }
127− return mark
150+ Solver $ \state ->
151+ let
152+ mark =
153+ sMark state
154+ in
155+ return ( mark, state { sMark = mark + 1 } )
128156
129157
158+{-# INLINE nextRankPool #-}
130159nextRankPool :: Solver Pool
131160nextRankPool =
132− do pool <- getPool
133− return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
161+ Solver $ \state ->
162+ let
163+ (Pool maxRank _) =
164+ sPool state
165+ in
166+ return ( Pool (maxRank + 1) [], state )
167+
134168
135169
170+-- REGISTER VARIABLES
171+
172+
173+{-# INLINE register #-}
136174register :: Variable -> Solver Variable
137175register variable =
138− do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
139− return variable
176+ Solver $ \state ->
177+ let
178+ (Pool maxRank inhabitants) =
179+ sPool state
180+ in
181+ return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
140182
141183
184+{-# INLINE introduce #-}
142185introduce :: Variable -> Solver Variable
143186introduce variable =
144− do pool <- getPool
145− State.liftIO $ UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank pool })
146− register variable
187+ Solver $ \state ->
188+ let
189+ (Pool maxRank inhabitants) =
190+ sPool state
191+ in
192+ do UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank })
193+ return ( variable, state { sPool = Pool maxRank (variable : inhabitants) } )
194+
195+
196+
197+-- FLATTEN
147198
148199
149200flatten :: Type -> Solver Variable
@@ -162,9 +213,9 @@ flattenHelp aliasDict termN =
162213 flatVar <- flattenHelp (Map.fromList flatArgs) realType
163214 pool <- getPool
164215 variable <-
165− State.liftIO . UF.fresh $ Descriptor
216+ liftIO . UF.fresh $ Descriptor
166217 { _content = Alias name flatArgs flatVar
167− , _rank = maxRank pool
218+ , _rank = _maxRank pool
168219 , _mark = noMark
169220 , _copy = Nothing
170221 }
@@ -177,15 +228,19 @@ flattenHelp aliasDict termN =
177228 do variableTerm <- traverseTerm (flattenHelp aliasDict) term1
178229 pool <- getPool
179230 variable <-
180− State.liftIO . UF.fresh $ Descriptor
231+ liftIO . UF.fresh $ Descriptor
181232 { _content = Structure variableTerm
182− , _rank = maxRank pool
233+ , _rank = _maxRank pool
183234 , _mark = noMark
184235 , _copy = Nothing
185236 }
186237 register variable
187238
188239
240+
241+-- MAKE INSTANCE
242+
243+
189244makeInstance :: Variable -> Solver Variable
190245makeInstance var =
191246 do alreadyCopiedMark <- uniqueMark
@@ -194,9 +249,13 @@ makeInstance var =
194249 return freshVar
195250
196251
252+
253+-- MAKE COPY
254+
255+
197256makeCopy :: Int -> Variable -> Solver Variable
198257makeCopy alreadyCopiedMark variable =
199− do desc <- State.liftIO $ UF.descriptor variable
258+ do desc <- liftIO $ UF.descriptor variable
200259 makeCopyHelp desc alreadyCopiedMark variable
201260
202261
@@ -220,9 +279,9 @@ makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =
220279 else
221280 do pool <- getPool
222281 newVar <-
223− State.liftIO $ UF.fresh $ Descriptor
282+ liftIO $ UF.fresh $ Descriptor
224283 { _content = content -- place holder!
225− , _rank = maxRank pool
284+ , _rank = _maxRank pool
226285 , _mark = noMark
227286 , _copy = Nothing
228287 }
@@ -233,12 +292,12 @@ makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =
233292 --
234293 -- Need to do this before recursively copying the content of
235294 -- the variable to avoid looping on cyclic terms.
236− State.liftIO $ UF.modifyDescriptor variable $ \desc ->
295+ liftIO $ UF.modifyDescriptor variable $ \desc ->
237296 desc { _mark = alreadyCopiedMark, _copy = Just newVar }
238297
239298
240299 let setContent newContent =
241− State.liftIO $ UF.modifyDescriptor newVar $ \desc ->
300+ liftIO $ UF.modifyDescriptor newVar $ \desc ->
242301 desc { _content = newContent }
243302
244303 -- Now we recursively copy the content of the variable.
@@ -291,9 +350,12 @@ needsCopy content =
291350
292351
293352
353+-- RESTORE
354+
355+
294356restore :: Int -> Variable -> Solver Variable
295357restore alreadyCopiedMark variable =
296− do desc <- State.liftIO $ UF.descriptor variable
358+ do desc <- liftIO $ UF.descriptor variable
297359 if _mark desc /= alreadyCopiedMark
298360 then
299361 return variable
@@ -301,7 +363,7 @@ restore alreadyCopiedMark variable =
301363 else
302364 do restoredContent <-
303365 restoreContent alreadyCopiedMark (_content desc)
304− State.liftIO $ UF.setDescriptor variable $ Descriptor
366+ liftIO $ UF.setDescriptor variable $ Descriptor
305367 { _content = restoredContent
306368 , _rank = noRank
307369 , _mark = noMark
@@ -339,17 +401,60 @@ restoreContent alreadyCopiedMark content =
339401-- TERM TRAVERSAL
340402
341403
342−traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
404+traverseTerm :: (a -> Solver b) -> Term1 a -> Solver (Term1 b)
343405traverseTerm f term =
344406 case term of
345407 App1 a b ->
346− App1 <$> f a <*> f b
408+ liftM2 App1 (f a) (f b)
347409
348410 Fun1 a b ->
349− Fun1 <$> f a <*> f b
411+ liftM2 Fun1 (f a) (f b)
350412
351413 EmptyRecord1 ->
352− return EmptyRecord1
414+ pure EmptyRecord1
353415
354416 Record1 fields ext ->
355− Record1 <$> traverse f fields <*> f ext
417+ liftM2 Record1 (traverse f fields) (f ext)
418+
419+
420+
421+-- INSTANCES
422+
423+
424+instance Functor Solver where
425+ {-# INLINE fmap #-}
426+ fmap f (Solver solver) = Solver $ \s1 ->
427+ fmap (\(a, s2) -> (f a, s2)) (solver s1)
428+
429+
430+instance Applicative Solver where
431+ {-# INLINE pure #-}
432+ pure a = Solver $ \s -> return (a, s)
433+
434+ {-# INLINE (<*>) #-}
435+ Solver solverFunc <*> Solver solverValue =
436+ Solver $ \s1 ->
437+ do (f, s2) <- solverFunc s1
438+ (x, s3) <- solverValue s2
439+ return (f x, s3)
440+
441+
442+instance Monad Solver where
443+ {-# INLINE (>>=) #-}
444+ Solver solver >>= k =
445+ Solver $ \s1 ->
446+ do (a, s2) <- solver s1
447+ (b, s3) <- _solve (k a) s2
448+ return (b, s3)
449+
450+ {-# INLINE fail #-}
451+ fail msg =
452+ Solver $ \_ -> fail msg
453+
454+
455+instance MonadIO Solver where
456+ {-# INLINE liftIO #-}
457+ liftIO io =
458+ Solver $ \state ->
459+ do a <- io
460+ return (a, state)