module Interactive(Interactive.interact, isInteractive) where
import Control.Exception as CE
import Control.Monad.Identity
import Control.Monad.Reader
import Data.Monoid
import System.IO(stdout)
import System.Environment
import Data.List(sort,isPrefixOf)
import Data.Maybe
import Text.Regex
import qualified Data.Map as Map
import DataConstructors
import Doc.DocLike
import Doc.PPrint
import Doc.Pretty
import FrontEnd.Desugar(desugarHsStmt)
import FrontEnd.HsParser(parseHsStmt)
import FrontEnd.HsPretty()
import FrontEnd.HsSyn
import FrontEnd.KindInfer
import FrontEnd.ParseMonad
import FrontEnd.Rename
import FrontEnd.Tc.Class
import FrontEnd.Tc.Main
import FrontEnd.Tc.Monad
import FrontEnd.Tc.Type
import FrontEnd.TypeSigs
import FrontEnd.TypeSynonyms(showSynonym)
import FrontEnd.TypeSyns
import FrontEnd.Warning
import GenUtil
import Ho.Type
import Name.Name
import Options
import Support.Compat
import Util.Interact
import Version.Version(versionString)
import qualified FrontEnd.HsPretty as HsPretty
import qualified FrontEnd.Infix
import qualified Text.PrettyPrint.HughesPJ as PP
printDoc doc = do
displayIO stdout (renderPretty 0.9 80 doc)
putStrLn ""
grep_opts = [
"f - match normal value",
"C - match data constructor",
"T - match type constructor",
"L - match class"
]
nameTag :: NameType -> Char
nameTag TypeConstructor = 'T'
nameTag DataConstructor = 'C'
nameTag ClassName = 'L'
nameTag Val = 'f'
nameTag _ = '?'
data InteractiveState = IS {
stateHo :: HoTcInfo,
stateInteract :: Interact,
stateModule :: Module,
stateImports :: [(Name,[Name])],
stateOptions :: Opt
}
isInitial = IS {
stateHo = mempty,
stateInteract = emptyInteract,
stateModule = mainModule,
stateImports = [],
stateOptions = options
}
newtype In a = MkIn (ReaderT InteractiveState IO a)
deriving(MonadIO,Monad,Functor,MonadReader InteractiveState)
runIn :: InteractiveState -> In a -> IO a
runIn is (MkIn x) = runReaderT x is
instance OptionMonad In where
getOptions = asks stateOptions
instance MonadWarn In where
addWarning x = liftIO $ addWarning x
interact :: CollectedHo -> IO ()
interact cho = mre where
hoE = hoTcInfo $ choHo cho
hoB = hoBuild $ choHo cho
mre = case optStmts options of
[] -> go
xs -> runInteractions initialInteract (concatMap lines $ reverse xs) >> exitSuccess
go = do
putStrLn "--------------------------------------------------------------"
putStrLn "Welcome to the Ajhc interactive experience. use :help for help."
putStrLn versionString
putStrLn "(This is not a full interpreter, but rather is used to"
putStrLn "help debug the compiler internals)"
putStrLn "--------------------------------------------------------------"
runInteraction initialInteract ":execfile ajhci.rc"
beginInteraction initialInteract
initialInteract = emptyInteract {
interactSettables = ["prog", "args"],
interactVersion = versionString,
interactCommands = commands,
interactWords = map (show . fst ) $ stateImports isStart,
interactHistFile = Just ".ajhci-hist",
interactComment = Just "--",
interactExpr = do_expr
}
dataTable = hoDataTable hoB
commands = [cmd_mods,cmd_grep]
cmd_mods = InteractCommand { commandName = ":mods", commandHelp = "mods currently loaded modules", commandAction = do_mods }
do_mods act _ _ = do
printDoc $ fillSep (map tshow $ Map.keys $ hoExports hoE)
return act
cmd_grep = InteractCommand { commandName = ":grep", commandHelp = "show names matching a regex", commandAction = do_grep }
do_grep act _ "" = do
putStrLn ":grep [options] <regex>"
putStrLn "Valid options:"
putStr $ unlines grep_opts
return act
do_grep act _ arg = do
let (opt,reg) = case simpleUnquote arg of
[x] -> ("TCLf",x)
xs -> f "" xs where
f opt [x] = (opt,x)
f opt ~(x:xs) = f (x ++ opt) xs
rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\(e::SomeException') -> return Nothing)
case rx of
Nothing -> putStrLn $ "Invalid regex: " ++ arg
Just rx -> mapM_ putStrLn $ sort [ pshow opt v | v <- Map.keys (hoDefs hoE), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]
return act
ptype x | Just r <- pprintTypeOfCons dataTable x = r
ptype k | Just r <- Map.lookup k (hoAssumps hoE) = show (pprint r:: PP.Doc)
ptype x | nameType x == ClassName = hsep (map kindShow $ kindOfClass x (hoKinds hoE))
ptype x = "UNKNOWN: " ++ show (nameType x,x)
isStart = isInitial { stateHo = hoE, stateImports = runIdentity $ calcImports hoE False preludeModule }
do_expr :: Interact -> String -> IO Interact
do_expr act s = case parseStmt (s ++ "\n") of
Left m -> putStrLn m >> return act
Right e -> do
CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show (e::SomeException'))
return act
pshow _opt v
| Just d <- showSynonym (show . (pprint :: HsType -> PP.Doc) ) v (hoTypeSynonyms hoE) = nameTag (nameType v):' ':d
| otherwise = nameTag (nameType v):' ':show v <+> "::" <+> ptype v
kindShow (KBase b) = pprint b
kindShow x = parens (pprint x)
parseStmt :: Monad m => String -> m HsStmt
parseStmt s = case snd $ runParserWithMode (parseModeOptions options) { parseFilename = "(jhci)" } parseHsStmt s of
ParseOk e -> return e
ParseFailed sl err -> fail $ show sl ++ ": " ++ err
printStatement stmt = do
liftIO $ putStrLn $ HsPretty.render $ HsPretty.ppHsStmt $ stmt
procErrors :: In a -> In ()
procErrors act = do
b <- liftIO $ printIOErrors
if b then return () else act >> return ()
executeStatement :: HsStmt -> In ()
executeStatement stmt = do
is@IS { stateHo = hoE } <- ask
stmt <- desugarHsStmt stmt
stmt' <- renameStatement mempty (stateImports is) (stateModule is) stmt
procErrors $ do
stmt'' <- expandTypeSynsStmt (hoTypeSynonyms hoE) (stateModule is) stmt'
stmt''' <- return $ FrontEnd.Infix.infixStatement (hoFixities hoE) stmt''
procErrors $ do
printStatement stmt'''
tcStatementTc stmt'''
tcStatementTc :: HsStmt -> In ()
tcStatementTc HsLetStmt {} = liftIO $ putStrLn "let statements not yet supported"
tcStatementTc HsGenerator {} = liftIO $ putStrLn "generators not yet supported"
tcStatementTc (HsQualifier e) = do
is@IS { stateHo = ho } <- ask
let tcInfo = tcInfoEmpty {
tcInfoEnv = (hoAssumps ho),
tcInfoSigEnv = collectSigEnv (hoKinds ho) (HsQualifier e),
tcInfoModName = (stateModule is),
tcInfoKindInfo = (hoKinds ho),
tcInfoClassHierarchy = (hoClassHierarchy ho)
}
runTc tcInfo $ do
box <- newBox kindFunRet
(_,ps') <- listenPreds $ tiExpr e box
ps' <- flattenType ps'
let ps = FrontEnd.Tc.Class.simplify (hoClassHierarchy ho) ps'
(ps :=> vv) <- flattenType (ps :=> box)
TForAll vs (ps :=> t) <- generalize ps vv
liftIO $ putStrLn $ "::" <+> prettyPrintType (TForAll vs (ps :=> t))
ce <- getCollectedEnv
liftIO $ mapM_ putStrLn [ pprint n <+> "::" <+> prettyPrintType s | (n,s) <- Map.toList ce]
calcImports :: Monad m => HoTcInfo -> Bool -> Module -> m [(Name,[Name])]
calcImports ho qual mod = case Map.lookup mod (hoExports ho) of
Nothing -> fail $ "calcImports: module not known " ++ show mod
Just es -> do
let ls = sortGroupUnderFG fst snd
[ (n,if qual then [setModule mod n] else [setModule mod n,toUnqualified n]) | n <- es]
ls' = concat [ zip (concat nns) (repeat [n]) | (n,nns) <- ls ]
return $ Map.toList $ Map.map snub $ Map.fromListWith (++) ls'
isInteractive :: IO Bool
isInteractive = do
pn <- getProgName
return $ (optMode options == Interactive)
|| "ichj" `isPrefixOf` reverse pn
|| not (null $ optStmts options)