String -> HermitName

Author: Andrew Farmer

src/HERMIT/Dictionary/Common.hs

@@ -48,7 +48,6 @@ import Data.List
 import Data.Monoid
 
 import Control.Arrow
-import Control.Monad
 import Control.Monad.IO.Class
 
 import HERMIT.Context
@@ -75,6 +74,7 @@ callT = contextfreeT $ \ e -> case e of
                                 App {} -> return (collectArgs e)
                                 _      -> fail "not an application or variable occurence."
 
+-- | Succeeds if we are looking at an application matching the given predicate.
 callPredT :: Monad m => (Id -> [CoreExpr] -> Bool) -> Transform c m CoreExpr (CoreExpr, [CoreExpr])
 callPredT p = do
     call@(Var i, args) <- callT
@@ -84,14 +84,10 @@ callPredT p = do
 -- | Succeeds if we are looking at an application of given function
 --   returning zero or more arguments to which it is applied.
 --
--- Note: function name is found using findIdT, then resulting Id is compared.
--- So callNameT "Data.Function.fix" works as expected.
--- If findIdT cannot find an Id, falls back to string comparison.
-callNameT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)
-          => String -> Transform c m CoreExpr (CoreExpr, [CoreExpr])
-callNameT nm = prefixFailMsg ("callNameT failed: not a call to '" ++ nm ++ ".") $ do
-    p <- liftM (==) (findIdT nm) <+ return (cmpString2Var nm)
-    callPredT (const . p)
+-- Note: comparison is performed with cmpHN2Var.
+callNameT :: MonadCatch m => HermitName -> Transform c m CoreExpr (CoreExpr, [CoreExpr])
+callNameT nm = prefixFailMsg ("callNameT failed: not a call to '" ++ show nm ++ ".")
+             $ callPredT (const . cmpHN2Var nm)
 
 -- | Succeeds if we are looking at a fully saturated function call.
 callSaturatedT :: Monad m => Transform c m CoreExpr (CoreExpr, [CoreExpr])
@@ -100,9 +96,8 @@ callSaturatedT = callPredT (\ i args -> idArity i == length args)
 --       idArity is conservatively set to zero by default.
 
 -- | Succeeds if we are looking at an application of given function
-callNameG :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)
-          => String -> Transform c m CoreExpr ()
-callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >>= \_ -> return ()
+callNameG :: MonadCatch m => HermitName -> Transform c m CoreExpr ()
+callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >> return ()
 
 -- | Succeeds if we are looking at an application of a data constructor.
 callDataConT :: MonadCatch m => Transform c m CoreExpr (DataCon, [Type], [CoreExpr])
@@ -200,22 +195,28 @@ findBoundVarT p = do
 --------------------------------------------------------------------------------------------------
 
 -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.
-findIdT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a Id
-findIdT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findId nm)
+findIdT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)
+        => HermitName -> Transform c m a Id
+findIdT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findId nm)
 
 -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.
-findVarT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a Var
-findVarT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findVar nm)
+findVarT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)
+         => HermitName -> Transform c m a Var
+findVarT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findVar nm)
 
 -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.
-findTyConT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a TyCon
-findTyConT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findTyCon nm)
+findTyConT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)
+           => HermitName -> Transform c m a TyCon
+findTyConT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findTyCon nm)
 
 -- | Lookup the name in the context first, then, failing that, in GHC's global reader environment.
-findTypeT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m) => String -> Transform c m a Type
-findTypeT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ contextonlyT (findType nm)
+findTypeT :: (BoundVars c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)
+          => HermitName -> Transform c m a Type
+findTypeT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $ contextonlyT (findType nm)
 
 -- TODO: "inScope" was defined elsewhere, but I've moved it here.  Should it be combined with the above functions?
+-- Used in Dictionary.Inline to check if variables an in scope.
+-- Used in Dictionary.Fold
 
 -- | Determine whether a variable is in scope.
 inScope :: ReadBindings c => c -> Var -> Bool

src/HERMIT/Dictionary/Composite.hs

@@ -14,14 +14,16 @@ module HERMIT.Dictionary.Composite
     ) where
 
 import Control.Arrow
-import Control.Monad.IO.Class
+
+import Data.String (fromString)
 
 import HERMIT.Context
 import HERMIT.Core
+import HERMIT.External
 import HERMIT.GHC
-import HERMIT.Monad
 import HERMIT.Kure
-import HERMIT.External
+import HERMIT.Monad
+import HERMIT.Name
 
 import HERMIT.Dictionary.Debug hiding (externals)
 import HERMIT.Dictionary.GHC hiding (externals)
@@ -56,19 +58,19 @@ externals =
 
 ------------------------------------------------------------------------------------------------------
 
-basicCombinators :: [String]
-basicCombinators = ["$",".","id","flip","const","fst","snd","curry","uncurry"]
+basicCombinators :: [HermitName]
+basicCombinators = map fromString ["$",".","id","flip","const","fst","snd","curry","uncurry"]
 
 -- | Unfold the current expression if it is one of the basic combinators:
 -- ('$'), ('.'), 'id', 'flip', 'const', 'fst', 'snd', 'curry', and 'uncurry'.
 --   This is intended to be used as a component of simplification traversals such as 'simplifyR' or 'bashR'.
-unfoldBasicCombinatorR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c
-                          , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )
+unfoldBasicCombinatorR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb
+                          , MonadCatch m )
                        => Rewrite c m CoreExpr
 unfoldBasicCombinatorR = setFailMsg "unfold-basic-combinator failed." $ unfoldNamesR basicCombinators
 
-simplifyR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c
-             , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )
+simplifyR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb
+             , MonadCatch m, MonadUnique m )
           => Rewrite c m Core
 simplifyR = setFailMsg "Simplify failed: nothing to simplify." $
     innermostR (   promoteBindR recToNonrecR
@@ -87,14 +89,14 @@ simplifyR = setFailMsg "Simplify failed: nothing to simplify." $
 -- basic combinators. See 'bashComponents' for a list of rewrites performed.
 -- Bash also performs occurrence analysis and de-zombification on the result, to update
 -- IdInfo attributes relied-upon by GHC.
-bashR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c
-         , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )
+bashR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb
+         , MonadCatch m, MonadUnique m )
       => Rewrite c m Core
 bashR = bashExtendedWithR []
 
 -- | An extensible bash. Given rewrites are performed before normal bash rewrites.
-bashExtendedWithR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c
-                     , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )
+bashExtendedWithR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb
+                     , MonadCatch m, MonadUnique m )
                   => [Rewrite c m Core] -> Rewrite c m Core
 bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents)
 
@@ -104,14 +106,13 @@ bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents)
 -- Note: core fragment which fails linting is still returned! Otherwise would behave differently than bashR.
 -- Useful for debugging the bash command itself.
 bashDebugR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb
-              , HasDebugChan m, HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m
-              , MonadThings m, MonadUnique m )
+              , HasDebugChan m, HasDynFlags m, MonadCatch m, MonadUnique m )
            => Rewrite c m Core
 bashDebugR = bashUsingR [ bracketR nm r >>> catchM (promoteT lintExprT >> idR) traceR
                         | (r,nm) <- bashComponents ]
 
 -- | Perform the 'bash' algorithm with a given list of rewrites.
-bashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, HasEmptyContext c, MonadCatch m)
+bashUsingR :: (AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadPath c Crumb, MonadCatch m)
            => [Rewrite c m Core] -> Rewrite c m Core
 bashUsingR rs = setFailMsg "bash failed: nothing to do." $
     repeatR (occurAnalyseR >>> onetdR (catchesT rs)) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR
@@ -136,8 +137,8 @@ bashHelp = "Iteratively apply the following rewrites until nothing changes:"
          : map snd (bashComponents :: [(RewriteH Core,String)] -- to resolve ambiguity
                                                                                        )
 -- TODO: Think about a good order for bash.
-bashComponents :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c
-                  , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )
+bashComponents :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb
+                  , MonadCatch m, MonadUnique m )
                => [(Rewrite c m Core, String)]
 bashComponents =
   [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr")    -- ??
@@ -173,13 +174,13 @@ bashComponents =
 -- | Smash is a more powerful but less efficient version of bash.
 -- Unlike bash, smash is not concerned with whether it duplicates work,
 -- and is intended for use during proving tasks.
-smashR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c
-          , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )
+smashR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb
+          , MonadCatch m, MonadUnique m )
        => Rewrite c m Core
 smashR = smashExtendedWithR []
 
-smashExtendedWithR :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c
-                      , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )
+smashExtendedWithR :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb
+                      , MonadCatch m, MonadUnique m )
                    => [Rewrite c m Core] -> Rewrite c m Core
 smashExtendedWithR rs = smashUsingR (rs ++ map fst smashComponents1) (map fst smashComponents2)
 
@@ -197,8 +198,8 @@ smashHelp = "A more powerful but less efficient version of \"bash\", intended fo
 
 
 -- | As bash, but with "let-nonrec-subst" instead of "let-nonrec-subst-safe".
-smashComponents1 :: ( ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasEmptyContext c
-                    , HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m )
+smashComponents1 :: ( AddBindings c, ExtendPath c Crumb, HasEmptyContext c, ReadBindings c, ReadPath c Crumb
+                    , MonadCatch m, MonadUnique m )
                  => [(Rewrite c m Core, String)]
 smashComponents1 =
   [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr")    -- ??

src/HERMIT/Dictionary/FixPoint.hs

@@ -19,6 +19,8 @@ import Control.Arrow
 import Control.Monad
 import Control.Monad.IO.Class
 
+import Data.String (fromString)
+
 import HERMIT.Context
 import HERMIT.Core
 import HERMIT.Monad
@@ -224,12 +226,12 @@ isFixExprT :: TransformH CoreExpr (Type,CoreExpr)
 isFixExprT = withPatFailMsg (wrongExprForm "fix t f") $ -- fix :: forall a. (a -> a) -> a
   do (Var fixId, [Type ty, f]) <- callT
      fixId' <- findIdT fixLocation
-     guardMsg (fixId == fixId') (unqualifiedName fixId ++ " does not match " ++ fixLocation)
+     guardMsg (fixId == fixId') (unqualifiedName fixId ++ " does not match " ++ show fixLocation)
      return (ty,f)
 
 --------------------------------------------------------------------------------------------------
 
-fixLocation :: String
-fixLocation = "Data.Function.fix"
+fixLocation :: HermitName
+fixLocation = fromString "Data.Function.fix"
 
 --------------------------------------------------------------------------------------------------

src/HERMIT/Dictionary/Fold.hs

@@ -8,7 +8,7 @@ module HERMIT.Dictionary.Fold
     , stashFoldAnyR
       -- * Unlifted fold interface
     , fold
-    , unifyTypes
+    , unifyTypes -- TODO: remove in favor of GHC's unification
     , tyMatchesToCoreExpr
     ) where
 
@@ -21,10 +21,11 @@ import qualified Data.Map as Map
 
 import HERMIT.Core
 import HERMIT.Context
-import HERMIT.Monad
-import HERMIT.Kure
 import HERMIT.External
 import HERMIT.GHC
+import HERMIT.Kure
+import HERMIT.Monad
+import HERMIT.Name
 
 import HERMIT.Dictionary.Common (varBindingDepthT,inScope,findIdT)
 import HERMIT.Dictionary.Inline hiding (externals)
@@ -35,7 +36,7 @@ import Prelude hiding (exp)
 
 externals :: [External]
 externals =
-    [ external "fold" (promoteExprR . foldR :: String -> RewriteH Core)
+    [ external "fold" (promoteExprR . foldR :: HermitName -> RewriteH Core)
         [ "fold a definition"
         , ""
         , "double :: Int -> Int"
@@ -69,13 +70,11 @@ stashFoldAnyR = setFailMsg "Fold failed: no definitions could be folded." $
                 catchesM =<< liftM (map stashFoldR) (liftM Map.keys (constT getStash))
 
 foldR :: (ReadBindings c, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m, MonadUnique m)
-      => String -> Rewrite c m CoreExpr
-foldR nm = prefixFailMsg "Fold failed: " $ do
-    v <- findIdT nm
-    foldVarR v Nothing
+      => HermitName -> Rewrite c m CoreExpr
+foldR nm = prefixFailMsg "Fold failed: " $ findIdT nm >>= foldVarR Nothing
 
-foldVarR :: (ReadBindings c, MonadCatch m, MonadUnique m) => Var -> Maybe BindingDepth -> Rewrite c m CoreExpr
-foldVarR v md = do
+foldVarR :: (ReadBindings c, MonadCatch m, MonadUnique m) => Maybe BindingDepth -> Var -> Rewrite c m CoreExpr
+foldVarR md v = do
     case md of
         Nothing    -> return ()
         Just depth -> do depth' <- varBindingDepthT v

src/HERMIT/Dictionary/Function.hs

@@ -17,6 +17,7 @@ import Control.Monad.IO.Class
 
 import Data.List (nub, intercalate, intersect, partition, transpose)
 import Data.Maybe (isNothing)
+import Data.String (fromString)
 
 import HERMIT.Context
 import HERMIT.Core
@@ -133,7 +134,7 @@ appArgM n e | n < 0     = fail "appArgM: arg must be non-negative"
 buildCompositionT :: (BoundVars c, HasDynFlags m, HasHermitMEnv m, HasHscEnv m, MonadCatch m, MonadIO m, MonadThings m)
                   => CoreExpr -> CoreExpr -> Transform c m x CoreExpr
 buildCompositionT f g = do
-    composeId <- findIdT "Data.Function.."
+    composeId <- findIdT $ fromString "Data.Function.."
     fDot <- buildApplicationM (varToCoreExpr composeId) f
     buildApplicationM fDot g
 
@@ -168,15 +169,15 @@ buildFixT :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m
           => CoreExpr -> Transform c m x CoreExpr
 buildFixT f = do
     (tvs, ty) <- endoFunExprTypeM f
-    fixId <- findIdT "Data.Function.fix"
+    fixId <- findIdT $ fromString "Data.Function.fix"
     f' <- substOrApply f [ (v, varToCoreExpr v) | v <- tvs ]
     return $ mkCoreLams tvs $ mkCoreApps (varToCoreExpr fixId) [Type ty, f']
 
 -- | Build an expression that is the monomorphic id function for given type.
 buildIdT :: (BoundVars c, HasHscEnv m, HasHermitMEnv m, MonadCatch m, MonadIO m, MonadThings m)
          => Type -> Transform c m x CoreExpr
 buildIdT ty = do
-    idId <- findIdT "Data.Function.id"
+    idId <- findIdT $ fromString "Data.Function.id"
     return $ mkCoreApp (varToCoreExpr idId) (Type ty)
 
 ------------------------------------------------------------------------------