167 lines
6.7 KiB
Haskell
167 lines
6.7 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2008 University of Kent
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
module CheckFramework where
|
|
|
|
import Control.Monad.Error
|
|
import Control.Monad.Reader
|
|
import Control.Monad.State
|
|
import Data.Generics
|
|
import Data.Maybe
|
|
import Control.Exception
|
|
|
|
import qualified AST as A
|
|
import UsageCheckUtils
|
|
import GenericUtils
|
|
import Traversal
|
|
import Utils
|
|
|
|
data CheckOptData = CheckOptData
|
|
{ ast :: A.AST
|
|
, parItems :: Maybe (ParItems ())
|
|
-- TODO also keep track of our location in each data structure
|
|
}
|
|
|
|
invalidateAll :: CheckOptData -> A.AST -> CheckOptData
|
|
invalidateAll d t = d { ast = t, parItems = Nothing}
|
|
|
|
newtype CheckOptM a = CheckOptM (ErrorT String (State CheckOptData) a)
|
|
deriving (Monad, MonadError String {-, MonadState CheckOptData-})
|
|
|
|
deCheckOptM :: CheckOptM a -> ErrorT String (State CheckOptData) a
|
|
deCheckOptM (CheckOptM x) = x
|
|
|
|
newtype CheckOptM' t a = CheckOptM' (RestartT A.AST t CheckOptM a)
|
|
deriving (Monad{-, MonadState (Route t A.AST)-})
|
|
|
|
deCheckOptM' :: CheckOptM' t a -> RestartT A.AST t CheckOptM a
|
|
deCheckOptM' (CheckOptM' x) = x
|
|
|
|
-- | The idea is this: in normal operation you use the Right return value. When
|
|
-- you want to restart the forAnyAST operation from a given point, you use the
|
|
-- Left constructor, supplying the route to use on the new tree (which you must
|
|
-- have put in the CheckOptM state) and the continuation to apply. If you wish
|
|
-- to start again from the top, supply routeIdentity, and your original function.
|
|
data Monad m => RestartT outer t m a = RestartT { getRestartT :: ReaderT (Route
|
|
t outer) m (Either (Route t outer, t -> RestartT outer t m a) a) }
|
|
|
|
instance Monad m => Monad (RestartT outer t m) where
|
|
return x = RestartT $ return $ Right x
|
|
(>>=) m f = let m' = getRestartT m in RestartT $ do
|
|
x <- m'
|
|
case x of
|
|
Left (route, cont) -> return $ Left (route, f <.< cont)
|
|
Right x' -> let m'' = getRestartT $ f x' in m''
|
|
|
|
liftRestartT :: Monad m => m a -> RestartT outer t m a
|
|
liftRestartT m = RestartT $ lift (m >>* Right)
|
|
|
|
elseError :: Bool -> String -> CheckOptM ()
|
|
elseError b err = CheckOptM $ if b then throwError err else return ()
|
|
|
|
forAnyParItems :: (ParItems a -> CheckOptM ()) -> CheckOptM ()
|
|
forAnyParItems = undefined
|
|
|
|
forAnyAST :: forall a. Data a => (a -> CheckOptM' a ()) -> CheckOptM ()
|
|
forAnyAST origF = CheckOptM $ do
|
|
tr <- get >>* ast
|
|
doTree typeSet (deCheckOptM' . origF) routeIdentity tr
|
|
where
|
|
typeSet :: TypeSet
|
|
typeSet = makeTypeSet [typeKey (undefined :: a)]
|
|
|
|
|
|
doTree :: Data t => TypeSet -> (a -> RestartT A.AST a CheckOptM ()) -> Route t A.AST -> A.AST -> ErrorT String (State CheckOptData) ()
|
|
doTree typeSet f route tr
|
|
= do x <- traverse typeSet f route tr
|
|
case x of
|
|
Left (route', cont) -> do
|
|
tr' <- get >>* ast
|
|
doTree typeSet cont route' tr'
|
|
Right _ -> return ()
|
|
|
|
traverse :: forall s. Data s => TypeSet -> (a -> RestartT A.AST a CheckOptM ()) -> Route s A.AST -> A.AST -> ErrorT String (State CheckOptData) (Either
|
|
(Route a A.AST, a -> RestartT A.AST a CheckOptM ()) ())
|
|
traverse typeSet f route tr = (deCheckOptM $ flip runReaderT undefined (getRestartT $ flip
|
|
evalStateT (Just route) $ gen tr))
|
|
>> return (Right ())
|
|
where
|
|
-- 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
|
|
-- a way through the maze of compiler errors. So with a glorious hack,
|
|
-- we tack on a state parameter with a (Maybe Route) and keep scanning
|
|
-- until we find the place to resume from (or go one past it, which is
|
|
-- nice in case the location is no longer valid)
|
|
|
|
gen :: A.AST -> StateT (Maybe (Route s A.AST)) (RestartT A.AST a CheckOptM) A.AST
|
|
gen x = gmapMForRoute typeSet (baseTransformRoute `extTransformRoute` (\(y, route) ->
|
|
do st <- get
|
|
case st of
|
|
Nothing -> lift $ apply typeSet f (y, route)
|
|
Just targetRoute -> if routeId targetRoute > routeId route then return y else do
|
|
put Nothing
|
|
lift $ apply typeSet f (y, route)
|
|
)) x
|
|
|
|
-- The return of this function is ignored. All changes should be done in the
|
|
-- state
|
|
apply :: TypeSet -> (a -> RestartT A.AST a CheckOptM ()) -> (a, Route a A.AST) -> RestartT A.AST a CheckOptM a
|
|
apply typeSet f (x, route)
|
|
= (RestartT $ ((local (const route) $ getRestartT (f x))))
|
|
>> (liftRestartT (CheckOptM get) >>* ast >>* routeGet route)
|
|
>>= gmapMForRoute typeSet (extTransformRoute baseTransformRoute $
|
|
\(y, route') -> apply typeSet f (y, route @-> route'))
|
|
|
|
|
|
-- | For both of these functions I'm going to need to mark all analyses as no longer
|
|
-- valid, but more difficult will be to maintain the current position (if possible
|
|
-- -- should be in substitute, but not necessarily in replace) and continue.
|
|
|
|
-- TODO uncomment and fix
|
|
--substitute :: a -> CheckOptM' a a
|
|
--substitute x = CheckOptM' $ RestartT $ return $ Left return
|
|
|
|
--replace :: t -> t -> CheckOptM' a ()
|
|
-- TODO think about what this means (replace everywhere, or just children?)
|
|
|
|
-- Restarts the current forAnyAST from the top of the tree, but keeps all changes
|
|
-- made thus far
|
|
|
|
-- TODO uncomment and fix
|
|
--restartForAnyAST :: CheckOptM' a b
|
|
--restartForAnyAST = CheckOptM' $ RestartT $ put routeIdentity >> return (Left return)
|
|
|
|
-- | Given a default value, followed by a function application with a
|
|
-- partial pattern match, gives back the default if the second parameter experiences
|
|
-- a pattern-match failure.
|
|
onlyIfPatternMatch :: a -> (b -> a) -> b -> IO a
|
|
onlyIfPatternMatch def f x = evaluate x >>= (\x' -> catchJust onlyPatternFail (evaluate
|
|
$ f x') (const $ return def))
|
|
where
|
|
onlyPatternFail (PatternMatchFail {}) = Just ()
|
|
onlyPatternFail _ = Nothing
|
|
|
|
--getParItems :: CheckOptM (ParItems ())
|
|
--getParItems = CheckOptM (\d -> Right (d, fromMaybe (generateParItems $ ast d) (parItems d)))
|
|
|
|
getParItems' :: CheckOptM' t (ParItems ())
|
|
getParItems' = undefined
|
|
|
|
generateParItems :: A.AST -> ParItems ()
|
|
generateParItems = undefined
|