lhc-0.6.20081127: src/Interactive.hs
{-# LANGUAGE CPP #-}
module Interactive(Interactive.interact) where
import Control.Monad.Reader
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Exception as CE
import Data.Monoid
import IO(stdout)
import List(sort)
import Maybe
import Monad
import qualified Data.Map as Map
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import Text.Regex
--import Text.Regex.Posix(regcomp,regExtended)
import DataConstructors
import Doc.DocLike
import Doc.PPrint
import Doc.Pretty
import FrontEnd.HsParser(parseHsStmt)
import FrontEnd.KindInfer
import FrontEnd.ParseMonad
import FrontEnd.Rename
import FrontEnd.Tc.Main
import FrontEnd.Tc.Monad
import FrontEnd.Tc.Type
import FrontEnd.Tc.Class
import FrontEnd.Desugar(desugarHsStmt)
import GenUtil
import Ho.Type
import Ho.Collected
import FrontEnd.HsPretty()
import FrontEnd.HsSyn
import Name.Name
import Options
import qualified FrontEnd.Infix
import qualified FrontEnd.HsPretty as HsPretty
import FrontEnd.TypeSynonyms(showSynonym)
import FrontEnd.TypeSyns
import FrontEnd.TypeSigs
import Util.Interact
import LHCVersion(versionString)
import FrontEnd.Warning
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 :: HoBuild,
stateInteract :: Interact,
stateModule :: Module,
stateImports :: [(Name,[Name])],
stateOptions :: Opt
}
isInitial = IS {
stateHo = mempty,
stateInteract = emptyInteract,
stateModule = Module "Main",
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 = hoExp $ 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 lhc interactive experience. use :help for help."
putStrLn versionString
putStrLn "--------------------------------------------------------------"
runInteraction initialInteract ":execfile lhci.rc"
beginInteraction initialInteract
initialInteract = emptyInteract {
interactSettables = ["prog", "args"],
interactVersion = versionString,
interactCommands = commands,
interactWords = map (show . fst ) $ stateImports isStart,
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
#if __GLASGOW_HASKELL__ >= 610
rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\(e::SomeException) -> return Nothing)
#else
rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\_ -> return Nothing)
#endif
case rx of
Nothing -> putStrLn $ "Invalid regex: " ++ arg
--Just rx -> mapM_ putStrLn $ sort [ nameTag (nameType v):' ':show v <+> "::" <+> ptype v | v <- Map.keys (hoDefs hoE), isJust (matchRegex rx (show v)), nameTag (nameType v) `elem` opt ]
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 hoB) = show (pprint r:: PP.Doc)
ptype x | nameType x == ClassName = hsep (map kindShow $ kindOfClass x (hoKinds hoB))
ptype x = "UNKNOWN: " ++ show (nameType x,x)
isStart = isInitial { stateHo = hoB, stateImports = runIdentity $ calcImports hoE False (Module "Prelude") }
do_expr :: Interact -> String -> IO Interact
do_expr act s = case parseStmt (s ++ "\n") of
Left m -> putStrLn m >> return act
Right e -> do
#if __GLASGOW_HASKELL__ >= 610
CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show (e::SomeException))
#else
CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show e)
#endif
return act
pshow _opt v
| Just d <- showSynonym (show . (pprint :: HsType -> PP.Doc) ) v (hoTypeSynonyms hoB) = 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 runParserWithMode (parseModeOptions options) { parseFilename = "(lhci)" } 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 = hoB } <- ask
stmt <- desugarHsStmt stmt
stmt' <- renameStatement mempty (stateImports is) (stateModule is) stmt
procErrors $ do
--printStatement stmt'
stmt'' <- expandTypeSynsStmt (hoTypeSynonyms hoB) (stateModule is) stmt'
stmt''' <- return $ FrontEnd.Infix.infixStatement (hoFixities hoB) stmt''
procErrors $ do
printStatement stmt'''
tcStatementTc stmt'''
{-
tcStatement :: HsStmt -> In ()
tcStatement HsLetStmt {} = liftIO $ putStrLn "let statements not yet supported"
tcStatement HsGenerator {} = liftIO $ putStrLn "generators not yet supported"
tcStatement (HsQualifier e) = do
tcStatementTc (HsQualifier e)
when False $ do
is@IS { stateHo = ho } <- ask
let importVarEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps ho, nameType x == Val ]
importDConsEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps ho, nameType x == DataConstructor ]
ansName = Qual (stateModule is) (HsIdent "ans")
ansName' = toName Val ansName
opt <- getOptions
localVarEnv <- liftIO $ TI.tiProgram
opt -- options
(stateModule is) -- name of the module
mempty -- environment of type signatures
(hoKinds ho) -- kind information about classes and type constructors
(hoClassHierarchy ho) -- class hierarchy with instances
importDConsEnv -- data constructor type environment
importVarEnv -- type environment
[([],[HsPatBind bogusASrcLoc (HsPVar ansName) (HsUnGuardedRhs e) []])] -- binding groups
[]
procErrors $ do
vv <- Map.lookup ansName' localVarEnv
liftIO $ putStrLn $ show (text "::" <+> pprint vv :: P.Doc)
-}
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 = show (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 -- quantify (tv vv) qt
--liftIO $ putStrLn $ show (text "::" <+> pprint vv' :: P.Doc)
liftIO $ putStrLn $ "::" <+> prettyPrintType (TForAll vs (ps :=> t))
ce <- getCollectedEnv
liftIO $ mapM_ putStrLn [ pprint n <+> "::" <+> prettyPrintType s | (n,s) <- Map.toList ce]
calcImports :: Monad m => HoExp -> 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'