suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Simplified the code slightly, since I was wrapping some things in a Maybe that didn't really need to be

Browse Source
This commit is contained in:
Neil Brown 2008-11-14 16:45:50 +00:00
parent e5ed7e07b7
commit c055b35d68
1 changed files with 10 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
checks/CheckFramework.hs
View File

@ -135,7 +135,7 @@ deCheckOptM' (CheckOptM' x) = x
-- have put in the CheckOptM state). If you wish -- have put in the CheckOptM state). If you wish
-- to start again from the top, supply routeIdentity, and your original function. -- to start again from the top, supply routeIdentity, and your original function.
data Monad m => RestartT m a data Monad m => RestartT m a
= RestartT { getRestartT :: m (Either (Maybe [Int]) a) } = RestartT { getRestartT :: m (Either [Int] a) }
instance Monad m => Monad (RestartT m) where instance Monad m => Monad (RestartT m) where
return x = RestartT $ return $ Right x return x = RestartT $ return $ Right x
@ -242,25 +242,22 @@ forAnyASTStruct origF = CheckOptM $ do
doTree :: TypeSet -> (forall a. Data a => a -> CheckOptM' a ()) -> doTree :: TypeSet -> (forall a. Data a => a -> CheckOptM' a ()) ->
[Int] -> A.AST -> StateT CheckOptData PassM () [Int] -> A.AST -> StateT CheckOptData PassM ()
doTree typeSet f route tr doTree typeSet f route tr
= do x <- traverse typeSet f (Just route) tr = do x <- traverse typeSet f route tr
case x of case x of
Left route' -> do -- Restart Left route' -> do -- Restart
tr' <- get >>* ast tr' <- get >>* ast
doTree typeSet f (fromMaybe [] route') tr' doTree typeSet f route' tr'
Right _ -> return () Right _ -> return ()
-- | Given a TypeSet, a function to apply to everything of type a, a route -- | Given a TypeSet, a function to apply to everything of type a, a route
-- location to begin at and an AST, transforms the tree. If any restarts are -- location to begin at and an AST, transforms the tree. If any restarts are
-- requested, that is indicated in the return value. If an AST is returned, -- requested, that is indicated in the return value. If an AST is returned,
-- it is ignored (all changes are done in the state) -- it is ignored (all changes are done in the state)
traverse :: TypeSet -> (forall a. Data a => a -> CheckOptM' a ()) -> Maybe [Int] -> A.AST -> traverse :: TypeSet -> (forall a. Data a => a -> CheckOptM' a ()) -> [Int] -> A.AST ->
StateT CheckOptData PassM (Either (Maybe [Int]) ()) StateT CheckOptData PassM (Either [Int] ())
traverse typeSet f route tr traverse typeSet f route tr
= deCheckOptM . getRestartT $ = deCheckOptM . getRestartT $
(flip evalStateT (case route of evalStateT (gen tr) (Just route)
Just r -> Just r
Nothing -> Just [] -- No route, means start from the beginning
) (gen tr))
where where
-- We can't use routeModify with the route to jump to the right place, -- We can't use routeModify with the route to jump to the right place,
-- because then applying gen gets much more difficult, and I can't find -- because then applying gen gets much more difficult, and I can't find
@ -307,7 +304,7 @@ substitute :: a -> CheckOptM' a ()
substitute x = CheckOptM' $ do substitute x = CheckOptM' $ do
r <- ask r <- ask
lift . lift . CheckOptM $ modify (invalidateAll $ routeSet r x) lift . lift . CheckOptM $ modify (invalidateAll $ routeSet r x)
lift . RestartT $ return $ Left (Just $ routeId r) lift . RestartT $ return $ Left (routeId r)
--replaceBelow :: t -> t -> CheckOptM' a () --replaceBelow :: t -> t -> CheckOptM' a ()
--replaceEverywhere :: t -> t -> CheckOptM' a () --replaceEverywhere :: t -> t -> CheckOptM' a ()
@ -316,7 +313,7 @@ substitute x = CheckOptM' $ do
-- Restarts the current forAnyAST from the top of the tree, but keeps all changes -- Restarts the current forAnyAST from the top of the tree, but keeps all changes
-- made thus far. -- made thus far.
restartForAnyAST :: CheckOptM' a a restartForAnyAST :: CheckOptM' a a
restartForAnyAST = CheckOptM' . lift . RestartT $ return $ Left Nothing restartForAnyAST = CheckOptM' . lift . RestartT $ return $ Left []
runChecks :: CheckOptM () -> A.AST -> PassM A.AST runChecks :: CheckOptM () -> A.AST -> PassM A.AST
runChecks (CheckOptM m) x = execStateT m (CheckOptData {ast = x, parItems = Nothing, runChecks (CheckOptM m) x = execStateT m (CheckOptData {ast = x, parItems = Nothing,
@ -341,8 +338,8 @@ generateParItems = todo
withChild :: forall t a. [Int] -> CheckOptM' () a -> CheckOptM' t a withChild :: forall t a. [Int] -> CheckOptM' () a -> CheckOptM' t a
withChild ns (CheckOptM' m) = askRoute >>= (CheckOptM' . lift . RestartT . inner) withChild ns (CheckOptM' m) = askRoute >>= (CheckOptM' . lift . RestartT . inner)
where where
inner :: Route t A.AST -> CheckOptM (Either (Maybe [Int]) a) inner :: Route t A.AST -> CheckOptM (Either [Int] a)
inner r = getRestartT $ runReaderT m (Route (routeId r ++ ns) (error "withChild attempted a substitution")) inner (Route rId rFunc) = getRestartT $ runReaderT m (Route (rId ++ ns) (error "withChild attempted a substitution"))
-- | Searches forward in the graph from the given node to find all the reachable -- | Searches forward in the graph from the given node to find all the reachable
-- nodes that have no successors, i.e. the terminal nodes -- nodes that have no successors, i.e. the terminal nodes