Finally wrestled the Haskell typechecker into submission to add my CheckFramework and its monads, which will hopefully do all that I need

This commit is contained in:
Neil Brown 2008-11-08 00:00:09 +00:00
parent d6b102838a
commit d0e2cd7b03
3 changed files with 187 additions and 1 deletions

View File

@ -33,6 +33,7 @@ import qualified Data.Set as Set
import ArrayUsageCheck
import qualified AST as A
import CheckFramework
import CompState
import Errors
import ExSet

166
checks/CheckFramework.hs Normal file
View File

@ -0,0 +1,166 @@
{-
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

View File

@ -28,7 +28,8 @@ module GenericUtils (
, containsTypes
, gmapMFor
, gmapMForRoute
, routeModify, routeGet, routeSet, Route
, routeModify, routeGet, routeSet, Route, (@->), routeIdentity, routeId
, baseTransformRoute, extTransformRoute
) where
import Control.Monad.Identity
@ -40,6 +41,7 @@ import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List
import Data.Typeable
import GHC.Base (unsafeCoerce#)
import System.IO.Unsafe
import qualified AST as A
@ -168,6 +170,9 @@ instance Eq (Route inner outer) where
instance Ord (Route inner outer) where
compare (Route xns _) (Route yns _) = compare xns yns
routeId :: Route inner outer -> [Int]
routeId (Route ns _) = ns
routeModify :: Monad m => Route inner outer -> (inner -> m inner) -> (outer -> m
outer)
routeModify (Route _ wrap) = wrap
@ -182,6 +187,9 @@ routeSet route x = runIdentity . routeModify route (const $ return x)
(@->) (Route outInds outF) (Route inInds inF) = Route (outInds ++ inInds) (outF
. inF)
routeIdentity :: Route a a
routeIdentity = Route [] id
gmapMForRoute :: forall m t. (Monad m, Data t) =>
TypeSet ->
(forall s. Data s => (s, Route s t) -> m s)
@ -204,6 +212,17 @@ gmapMWithRoute f = gmapFuncs [GM {unGM = f' n} | n <- [0..]]
f' :: Int -> (forall b. Data b => b -> m b)
f' n x = f (x, makeRoute n)
baseTransformRoute :: forall m s t. (Data s, Monad m) => (s, Route s t) -> m s
baseTransformRoute (x, _) = return x
extTransformRoute :: forall s m t. (Data s, Monad m) => (forall a. Data a => (a, Route a t) -> m a) -> ((s, Route s t) -> m
s) -> (forall a. Data a => (a, Route a t) -> m a)
extTransformRoute generalFunc specificFunc (x, route)
= case cast x of
Just x' -> do Just y <- specificFunc (x', unsafeCoerce# route) >>* cast
return y
Nothing -> generalFunc (x, route)
-- Given a number, makes a route function for that child:
makeRoute :: (Data s, Data t) => Int -> Route s t
makeRoute target = Route [target] (\f -> gmapFuncs [mkM' (if n == target then f else return) | n <- [0..]])