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

checks/Check.hs

@@ -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

checks/CheckFramework.hs

@@ -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

common/GenericUtils.hs

@@ -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..]])