git.iko.soy/elk
on master help sign in
style: conform to modern style
6b0badbEvan Czaplicki
src/Type/State.hs+108−71
compare with master
unifiedsplit
@@ -1,3 +1,4 @@
1+{-# LANGUAGE FlexibleContexts #-}
1module Type.State where
2module Type.State where
2
3
3import Control.Applicative ( (<$>), (<*>), Applicative, (<|>) )
4import Control.Applicative ( (<$>), (<*>), Applicative, (<|>) )
@@ -21,29 +22,47 @@ data Pool = Pool
21 , inhabitants :: [Variable]
22 , inhabitants :: [Variable]
22 }
23 }
23
24
25+
26+emptyPool :: Pool
27+emptyPool =
28+ Pool
24−emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }
29+ { maxRank = outermostRank
30+ , inhabitants = []
31+ }
32+
25
33
26type Env = Map.Map String Variable
34type Env = Map.Map String Variable
27
35
36+
28-- Keeps track of the environment, type variable pool, and a list of errors
37-- Keeps track of the environment, type variable pool, and a list of errors
29−data SolverState = SS {
38+data SolverState = SS
30− sEnv :: Env,
39+ { sEnv :: Env
31− sSavedEnv :: Env,
40+ , sSavedEnv :: Env
32− sPool :: Pool,
41+ , sPool :: Pool
33− sMark :: Int,
42+ , sMark :: Int
34− sErrors :: [P.Doc]
43+ , sErrors :: [P.Doc]
35−}
44+ }
36−
45+
46+
37−initialState = SS {
47+initialState :: SolverState
48+initialState =
49+ SS
38− sEnv = Map.empty,
50+ { sEnv = Map.empty
39− sSavedEnv = Map.empty,
51+ , sSavedEnv = Map.empty
40− sPool = emptyPool,
52+ , sPool = emptyPool
41− sMark = noMark + 1, -- The mark must never be equal to noMark!
53+ , sMark = noMark + 1 -- The mark must never be equal to noMark!
42− sErrors = []
54+ , sErrors = []
43−}
55+ }
44−
56+
57+
58+modifyEnv :: (MonadState SolverState m) => (Env -> Env) -> m ()
59+modifyEnv f =
45−modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
60+ modify $ \state -> state { sEnv = f (sEnv state) }
61+
62+
63+modifyPool :: (MonadState SolverState m) => (Pool -> Pool) -> m ()
64+modifyPool f =
46−modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
65+ modify $ \state -> state { sPool = f (sPool state) }
47
66
48
67
49addError
68addError
@@ -72,68 +91,84 @@ addError region hint t1 t2 =
72 , P.nest 8 $ A.getRegionDocs region
91 , P.nest 8 $ A.getRegionDocs region
73 ]
92 ]
74
93
94+
95+switchToPool :: (MonadState SolverState m) => Pool -> m ()
75−switchToPool pool = modifyPool (\_ -> pool)
96+switchToPool pool =
97+ modifyPool (\_ -> pool)
98+
76
99
77getPool :: StateT SolverState IO Pool
100getPool :: StateT SolverState IO Pool
78−getPool = sPool <$> get
101+getPool =
102+ gets sPool
103+
79
104
80getEnv :: StateT SolverState IO Env
105getEnv :: StateT SolverState IO Env
81−getEnv = sEnv <$> get
106+getEnv =
107+ gets sEnv
108+
82
109
83saveLocalEnv :: StateT SolverState IO ()
110saveLocalEnv :: StateT SolverState IO ()
84−saveLocalEnv = do
111+saveLocalEnv =
85− env <- sEnv <$> get
112+ do env <- sEnv <$> get
86− modify $ \state -> state { sSavedEnv = env }
113+ modify $ \state -> state { sSavedEnv = env }
114+
87
115
88uniqueMark :: StateT SolverState IO Int
116uniqueMark :: StateT SolverState IO Int
89−uniqueMark = do
117+uniqueMark =
90− state <- get
118+ do state <- get
91− let mark = sMark state
119+ let mark = sMark state
92− put $ state { sMark = mark + 1 }
120+ put $ state { sMark = mark + 1 }
93− return mark
121+ return mark
122+
94
123
95nextRankPool :: StateT SolverState IO Pool
124nextRankPool :: StateT SolverState IO Pool
96−nextRankPool = do
125+nextRankPool =
97− pool <- getPool
126+ do pool <- getPool
98− return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
127+ return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }
128+
99
129
100register :: Variable -> StateT SolverState IO Variable
130register :: Variable -> StateT SolverState IO Variable
101−register variable = do
131+register variable =
102− modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
132+ do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }
103− return variable
133+ return variable
134+
104
135
105introduce :: Variable -> StateT SolverState IO Variable
136introduce :: Variable -> StateT SolverState IO Variable
106−introduce variable = do
137+introduce variable =
107− pool <- getPool
138+ do pool <- getPool
108− liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
139+ liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })
109− register variable
140+ register variable
141+
110
142
111flatten :: Type -> StateT SolverState IO Variable
143flatten :: Type -> StateT SolverState IO Variable
112flatten term =
144flatten term =
113 case term of
145 case term of
114− VarN maybeAlias v -> do
146+ VarN maybeAlias v ->
115− liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = maybeAlias <|> alias desc }
147+ do liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = maybeAlias <|> alias desc }
116− return v
148+ return v
149+
117− TermN maybeAlias t -> do
150+ TermN maybeAlias t ->
118− flatStructure <- traverseTerm flatten t
151+ do flatStructure <- traverseTerm flatten t
119− pool <- getPool
152+ pool <- getPool
120− var <- liftIO . UF.fresh $ Descriptor
153+ var <- liftIO . UF.fresh $ Descriptor
121− { structure = Just flatStructure
154+ { structure = Just flatStructure
122− , rank = maxRank pool
155+ , rank = maxRank pool
123− , flex = Flexible
156+ , flex = Flexible
124− , name = Nothing
157+ , name = Nothing
125− , copy = Nothing
158+ , copy = Nothing
126− , mark = noMark
159+ , mark = noMark
127− , alias = maybeAlias
160+ , alias = maybeAlias
128− }
161+ }
129− register var
162+ register var
163+
130
164
131makeInstance :: Variable -> StateT SolverState IO Variable
165makeInstance :: Variable -> StateT SolverState IO Variable
132−makeInstance var = do
166+makeInstance var =
133− alreadyCopied <- uniqueMark
167+ do alreadyCopied <- uniqueMark
134− freshVar <- makeCopy alreadyCopied var
168+ freshVar <- makeCopy alreadyCopied var
135− restore alreadyCopied var
169+ restore alreadyCopied var
136− return freshVar
170+ return freshVar
171+
137
172
138makeCopy :: Int -> Variable -> StateT SolverState IO Variable
173makeCopy :: Int -> Variable -> StateT SolverState IO Variable
139makeCopy alreadyCopied variable = do
174makeCopy alreadyCopied variable = do
@@ -184,17 +219,19 @@ makeCopy alreadyCopied variable = do
184 desc { structure = Just newTerm }
219 desc { structure = Just newTerm }
185 return newVar
220 return newVar
186
221
222+
187restore :: Int -> Variable -> StateT SolverState IO Variable
223restore :: Int -> Variable -> StateT SolverState IO Variable
188−restore alreadyCopied variable = do
224+restore alreadyCopied variable =
189− desc <- liftIO $ UF.descriptor variable
225+ do desc <- liftIO $ UF.descriptor variable
190− if mark desc /= alreadyCopied
226+ case mark desc /= alreadyCopied of
191− then return variable
227+ True -> return variable
192− else do
228+ False ->
193− restoredStructure <-
229+ do restoredStructure <-
194− Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
230+ Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)
195− liftIO $ UF.modifyDescriptor variable $ \desc ->
231+ liftIO $ UF.modifyDescriptor variable $ \desc ->
196− desc { mark = noMark, rank = noRank, structure = restoredStructure }
232+ desc { mark = noMark, rank = noRank, structure = restoredStructure }
197− return variable
233+ return variable
234+
198
235
199traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
236traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)
200traverseTerm f term =
237traverseTerm f term =