Commit 2a7337ac authored by bbr's avatar bbr
Browse files

Various improvements for debugger

- problem with not imported constructors fixed by adding compiler flag to use fcy instead of fint
- improved error message for type map
- improved test for good global definitions
- module Meta compilable by prophecy by adding headNormalFormIO to apply functions
- fixed bug with ho-constructors in Transform.curry
parent 075955d9
......@@ -87,7 +87,7 @@ data Options = Opts{ cm :: ChoiceMode,
userlibpath, done :: [String],
verbosity :: Int,
make, executable, eval,
force, debug :: Bool,
force, debug, doNotUseInterface :: Bool,
consUse :: ConsUse,
extCons,hasData :: Bool,
pm :: PresentationMode,
......@@ -149,6 +149,7 @@ defaultOpts curDir = Opts {cm=CTC,filename="", mainFunc= "main", mainModule="Mai
eval=True,
force=False,
debug=False,
doNotUseInterface=False,
consUse=FunctionDef,
extCons=False,
hasData=False,
......
......@@ -83,7 +83,10 @@ process opts0@(Opts{filename=fn}) = do
-- only read beginning of interface file, return name and list of imports
skip :: Options -> Safe IO (String,[String],Options)
skip opts = do
fn <- safeIO (findFileInPath (filename opts++".fint") (libpath opts)) >>=
let fname = if doNotUseInterface opts
then filename opts++".fcy"
else filename opts++".fint"
fn <- safeIO (findFileInPath fname (libpath opts)) >>=
warning (filename opts) (cmdLibpath opts)
cont <- safeIOSeq (readFile fn)
let [("Prog",rest)] = lex cont
......@@ -128,9 +131,12 @@ applyFlatTransformations opts prog = do
mexprog = if executable opts then addExec auxNames opts prog
else Left prog
exprog <- either return fail mexprog
interfaces <- mapM (safeReadFlat opts . (++".fint")) (progImports exprog)
let (globals,locProg) = splitGlobals exprog
liftedProg = noCharCase (liftCases True locProg)
let suffix = if doNotUseInterface opts
then (++".fcy")
else (++".fint")
interfaces <- mapM (safeReadFlat opts . suffix) (progImports exprog)
(globals,locProg) <- safeIOSeq (return (splitGlobals exprog))
let liftedProg = noCharCase (liftCases True locProg)
--disAmb <- disambiguate interfaces ceprog
unless (null globals)
(put 5 opts
......
......@@ -224,9 +224,11 @@ pre s = ("Prelude",s)
------------------------------------------------------------
makeTypeMap :: [Prog] -> QName -> QName
makeTypeMap ps = \s->maybe (error ("type map: "++show s)) id (myLookup s fm)
makeTypeMap ps s = maybe (errorMsg s) id (myLookup s fm)
where
fm = myFromList (concatMap typeMapTypeDecl (concatMap typeDecls ps))
errorMsg (m,n) = error ("PreTrans.makeTypeMap: cannot find type"++
" of constructor "++m++"."++n)
typeMapTypeDecl (TypeSyn _ _ _ _) = []
typeMapTypeDecl (Type typeName _ _ consDecls) =
......@@ -241,17 +243,38 @@ typeDecls (Prog _ _ ts _ _) = ts
splitGlobals :: Prog -> ([FuncDecl],Prog)
splitGlobals prog
| progName prog == "Global" = ([],prog)
| all okDef gs = (gs,updProgFuncs (const fs) prog)
| otherwise = error $ "incorrect global definition(s) "
++ show (map funcName (filter (not . okDef) gs))
| all okDef toTest = (gs,updProgFuncs (const fs) prog)
| otherwise = error $ "function global not allowed in this context "
++ show (map funcName (filter (not . okDef) gs))
where
(gs,fs) = partition (isGlobal . resultType . funcType) (progFuncs prog)
(toTest,noGlobal) = partition (containsGlobal . resultType . funcType)
(progFuncs prog)
(gs,fs) = partition isGlobalDecl (progFuncs prog)
isGlobal (TCons ("Global","Global") _) = True
isGlobal _ = False
isGlobalDecl f = isGlobal (funcType f) && isGlobalDef (funcBody f)
containsGlobal (TVar _) = False
containsGlobal t@(TCons _ args) = isGlobal t || any containsGlobal args
containsGlobal (FuncType _ _) = False
isGlobalDef (Comb FuncCall ("Global","global") _) = True
isGlobalDef _ = False
okDef f = isGlobal (funcType f) && isGlobalDef (funcBody f)
&& isMonomorph (funcType f)
okDef f
| isGlobal (funcType f) && isGlobalDef (funcBody f) =
isMonomorph (funcType f)
| otherwise = noCallToGlobal (funcBody f)
noCallToGlobal = trExpr (\_->True) (\_->True)
(\ _ n args -> n/=("Global","global")
&& and args)
(\bs e->and (e:map snd bs))
(\_ ->id) (&&)
(\_ e bs -> and (e:bs)) (\_->id)
isMonomorph :: TypeExpr -> Bool
isMonomorph (TVar _) = False
......
......@@ -131,9 +131,11 @@ setMenue (opt:vals) state opts = do
['+':settings] -> shortSettings True state opts settings
['-':settings] -> shortSettings False state opts settings
_ -> putStrLn ("invalid setting. Example \":set ctc\" to " ++
"set choice mode to call-time choice") >> interactive state opts
"set choice mode to call-time choice") >>
interactive state opts
longSetting flag state opts "debug" = interactive state opts{debug=flag}
longSetting flag state opts "debug" =
interactive state opts{debug=flag,doNotUseInterface=flag}
longSetting flag state opts "time" = interactive state{time=flag} opts
longSetting flag state opts "eval" = interactive state opts{eval=flag}
longSetting flag state opts "make" = interactive state opts{make=flag}
......@@ -150,7 +152,7 @@ shortSettings flag state opts ('+':settings) =
shortSettings flag state opts (c:settings) =
shortSettings flag state (newOpts c) settings
where
newOpts 'd' = opts{debug=flag}
newOpts 'd' = opts{debug=flag,doNotUseInterface=flag}
newOpts 'e' = opts{eval=flag}
newOpts 'm' = opts{make=flag}
newOpts 'f' = opts{force=flag}
......
......@@ -18,6 +18,7 @@ module Oracle (
import IOExts
import Unsafe
import System (getProgName)
import qualified Meta
--import Global
--extFileName :: Global String
......@@ -63,6 +64,12 @@ apply f x r = f r x
($##) :: (Ref -> a -> b) -> a -> Ref -> b
($##) f x r = f r Prelude.$## x
headNormalFormIO :: (Ref -> a -> IO b) -> a -> Ref -> IO b
headNormalFormIO f x r = Meta.headNormalFormIO (f r) x
--- Wrapper for bind in io monad
(>>=) :: (IO a) -> (Ref -> a -> IO b) -> Ref -> IO b
(>>=) a b r = (Prelude.>>=) a (b r)
......
......@@ -56,7 +56,7 @@ emptyBoolStack :: BoolStack
emptyBoolStack = [0]
--- implementation of push/pop
--- makes sure that this is an infinite list of Tures:
--- makes sure that this is an infinite list of Trues:
allTrue :: BoolStack
allTrue = []
......
......@@ -16,7 +16,8 @@ import Wrapper
import Make
applyFuncs = zip (repeat prelude) ["apply","$!","$!!","$#","$##",">>="]
applyFuncs = ("Meta","headNormalFormIO") :
zip (repeat prelude) ["apply","$!","$!!","$#","$##",">>="]
specialIOs = zip (repeat prelude) ["return","catchFail","getSearchTree"]
addOrc s = newModName s
addFcy = (++".fcy")
......@@ -65,13 +66,8 @@ transProg prog
isTrCons c = elem c $ map consName $ concatMap typeConsDecls typesToTransform
hasHOTypeArg :: TypeDecl -> Bool
hasHOTypeArg = trType (\_ _ _ cs -> any isHOType (concatMap consArgs cs)) (\ _ _ _ _ -> False)
isHOType :: TypeExpr -> Bool
isHOType (TVar _) = False
isHOType (TCons _ args) = any isHOType args
isHOType (FuncType dom rng) =
trTypeExpr (\_ -> False) (\ _ -> or) (\_ _ -> True) dom || isHOType rng
hasHOTypeArg = trType (\_ _ _ cs -> any isFuncType (concatMap consArgs cs))
(\_ _ _ _ -> False)
transType :: (QName -> Bool) -> TypeDecl -> TypeDecl
transType isTr = updTypeName newModNameQ .
......@@ -84,11 +80,14 @@ rType :: (QName -> Bool) -> TypeExpr -> TypeExpr
rType _ t@(TVar _) = t
rType isTr (TCons name args) = TCons (when isTr newModNameQ name) (map (rType isTr) args)
rType isTr (FuncType dom ran) =
FuncType tRef (FuncType (updQNamesInTypeExpr (when isTr newModNameQ) dom) (rType isTr ran))
FuncType tRef (FuncType (updQNamesInTypeExpr (when isTr newModNameQ)
(rType isTr dom))
(rType isTr ran))
transFunc :: (QName -> Bool) -> Options -> FuncDecl -> [FuncDecl]
transFunc isTr opts func@(Func name arity vis t _)
| isExternal func
| name==("Global","global") = []
| isExternal func || isGlobal func
= if name `elem` applyFuncs
then []
else let maySafe e = if isComplexIOType (resultType t)
......@@ -117,7 +116,13 @@ transFunc isTr opts func@(Func name arity vis t _)
newName = newModNameQ name
isComplexIOType (TVar _) = False
isComplexIOType (TCons (m,n) as) =
m==prelude && n=="IO" && as/=[TCons (prelude,"()") []] && not (elem name specialIOs)
m==prelude && n=="IO"
&& as/=[TCons (prelude,"()") []]
&& not (elem name specialIOs)
isGlobal f = case funcBody f of
Comb FuncCall g [_,_] -> g==("Global","global")
_ -> False
transFuncType :: Int -> (QName -> Bool) -> TypeExpr -> TypeExpr
transFuncType 0 isTr t@(TVar _) = FuncType tRef (rType isTr t)
......
......@@ -33,7 +33,8 @@ consTerm = "consTerm"
debugMonad = "Debug"
extModPrefix = "ExternalStrict"
impPrelude = "Prelude (Maybe(..),(.),Eq(..),Show(..),\n\
\ Ordering(..),Either(..),String,Bool(..),Char(..),Float(..))\n\
\ Ordering(..),Either(..),String,\
\Bool(..),Char(..),Float(..))\n\
\import qualified Prelude (IO,return,(>>=))"
applyFuns :: [String]
......@@ -85,19 +86,21 @@ mStepFile s = case s of
_ -> Nothing
parseArgs :: IO Args
parseArgs = do args <- getArgs
if (null args)
then error "usage: stricths [-c|--curry] [-f|--force] [-m|--make]\
\[-s<filename>|--stepfile<filename>] <modulename>"
else return (any isForce args,
any isMake args,
maybe (last args) id
(listToMaybe (catMaybes (map mStepFile args))),
last args)
where last xs = xs !! (length xs-1)
parseArgs = do
args <- getArgs
if (null args)
then error "usage: stricths [-c|--curry] [-f|--force] [-m|--make]\
\[-s<filename>|--stepfile<filename>] <modulename>"
else return (any isForce args,
any isMake args,
maybe (last args) id
(listToMaybe (catMaybes (map mStepFile args))),
last args)
where last xs = xs !! (length xs-1)
transform :: String -> Bool -> Bool -> String -> IO ()
transform stFile _ False progName = readFlatCurry progName >>= writeTrans stFile ""
transform stFile _ False progName =
readFlatCurry progName >>= writeTrans stFile ""
transform stFile force True progName = make progName tester (writeTrans stFile)
where
tester = if force then (\ _ _ -> return True)
......@@ -238,7 +241,7 @@ complexShowCall vs@(_:_) consname =
addFtraceCall :: String -> FuncDecl -> [FuncDecl]
addFtraceCall stFile f
| isExternal f = []
| isExternalOrGlobal f = []
| fname == "expression" = traced iotype (libcall traceFun
[string stFile, funcBody f])
| otherwise = traced (funcType f) (expr' (funcBody f))
......@@ -280,6 +283,11 @@ string = foldr (colon . Lit . Charc) nil
isApplyName :: QName -> Bool
isApplyName (m,n) = m==prelude && elem n applyFuns
isExternalOrGlobal f =
isExternal f || case funcType f of
FuncType _ (TCons g [_]) -> g==("Global","Global")
_ -> False
intToInt Zero = "Zero"
intToInt (Pos n) = "(Pos "++natToNat n++")"
intToInt (Neg n) = "(Neg "++natToNat n++")"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment