Commit bcbc4d33 authored by bbr's avatar bbr
Browse files

towards transforming strict prelude

- dependencies in Makefile updated for stricths
- fixed a bug in compiler from adding debug mode
- added back quotes to Pretty library
- added banner and better interaction to strict steps
- many improves in PrettyStrict to make haskell conform code
- added make capability to stricths
- as yet removed tuples and lists
- changed treatment of main function
- added external definition
parent 1207b7c5
......@@ -83,7 +83,7 @@ dist:
oracle: $(BIN)stricths $(BIN)prophecy
$(BIN)stricths:
$(BIN)stricths: $(ORACLE)stricths.curry
$(KICS) -executable -o $(BIN)stricths -userlibpath $(ORACLE) stricths.curry
$(BIN)prophecy: $(ORACLE)Transform.curry
......
......@@ -324,8 +324,8 @@ addExec (aux1,aux2) opts (Prog m is ts funcs ops) =
| isIOType t -> prog True
[Func a1 0 vis (monomorph t) (Rule [] (flatApp n [])),
Func a2 0 vis (ioT unitT) (Rule [] (flatApp printIO [calla1 t]))]
| isFuncType t && not (debug opts)
|| isFuncType (range t) -> Right (mainFunc opts++" is no constant")
| isFuncType t && (not (debug opts) && not (isFuncType (range t)))
-> Right (mainFunc opts++" is no constant")
| debug opts -> prog True
[Func a1 1 vis (monomorph t) (Rule [0] (flatApp n [Var 0])),
Func a2 0 vis (ioT unitT) (Rule []
......
......@@ -27,7 +27,7 @@ module Pretty (
punctuate, encloseSep, fillEncloseSep, list, tupled, semiBraces,
-- bracketing combinators
enclose, squotes, dquotes, parens, angles, braces, brackets,
enclose, squotes, dquotes, bquotes, parens, angles, braces, brackets,
-- primitve type documents
char, string, int, float,
......@@ -129,6 +129,7 @@ enclose l r d = l <> d <> r
squotes, dquotes, parens, angles, braces, brackets :: Doc -> Doc
squotes = enclose squote squote
dquotes = enclose dquote dquote
bquotes = enclose bquote bquote
parens = enclose lparen rparen
angles = enclose langle rangle
braces = enclose lbrace rbrace
......@@ -147,7 +148,8 @@ float :: Float -> Doc
float x = text (show x)
lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,
squote, dquote, semi, colon, comma, space, dot, backslash, equals :: Doc
squote, dquote, bquote, semi, colon, comma, space, dot, backslash,
equals :: Doc
lparen = char '('
rparen = char ')'
langle = char '<'
......@@ -158,6 +160,7 @@ lbracket = char '['
rbracket = char ']'
squote = char '\''
dquote = char '\"'
bquote = char '`'
semi = char ';'
colon = char ':'
comma = char ','
......
......@@ -23,7 +23,7 @@ infixIDs :: String
infixIDs = "~!@#$%^&*+-=<>?./|\\:"
isTupleName :: QName -> Bool
isTupleName (mod,name) = mod == prelude && elem (take 2 name) ["()","(,"]
isTupleName (_,name) = elem (take 2 name) ["()","(,"]
showStyledProg :: Bool -> Prog -> String
showStyledProg isHs = pretty 78 . progDoc isHs . updProgExps elimApp
......@@ -75,35 +75,55 @@ app d ds = if null ds then d
layout :: [Doc] -> Doc
layout = align . compose (combine (linesep "; "))
qname :: String -> QName -> Doc
qname prog mn@(mod,name)
| mn == (prelude,"[]") || isTupleName mn = operator (text name)
| isInfixName mn = parens (operator (text name))
| otherwise
= if mod `elem` [prelude,prog]
then txt name
else consname mod <> dot <> (txt name)
where
txt (n:ame) = if isUpper n then consname (n:ame) else text (n:ame)
qname :: Bool -> QName -> Doc
qname = qname' True
qname' :: Bool -> Bool -> QName -> Doc
qname' b fun mn@(mod,name)
| name == "[]" || isTupleName mn = operator (text name)
| name ==":" = identifier' b fun mn
| isInfixName mn = maybeParens b (consname mod <> dot <> identifier' False fun mn)
| otherwise = consname mod <> dot <> identifier' b fun mn
identifier :: Bool -> QName -> Doc
identifier = identifier' True
identifier' :: Bool -> Bool -> QName -> Doc
identifier' b fun n
| isInfixName n = maybeParens b (operator (text (snd n)))
| fun = text (snd (funId n))
| otherwise = consname (snd (consId n))
funId :: QName -> QName
funId (m,n) = (m,toLower (head n) : tail n)
consId :: QName -> QName
consId (m,n) = (m,toUpper (head n) : tail n)
maybeParens :: Bool -> Doc -> Doc
maybeParens True = parens
maybeParens False = id
d1 <$>> d2 = d1 <$> line <> d2
progDoc :: Bool -> Prog -> Doc
progDoc isHs prog@(Prog name imps types funcs ops)
= moduleHeaderDoc name (exportedNames name prog) <$>>
= moduleHeaderDoc name (exportedNames prog) <$>>
impsDoc imps <$>> opsDoc ops <$>>
typesDoc isHs name types <$>>
funcsDoc name funcs
exportedNames :: String -> Prog -> [Doc]
exportedNames mod (Prog _ _ types funcs _)
exportedNames :: Prog -> [Doc]
exportedNames (Prog _ _ types funcs _)
= map typeExpDoc (filter ((Public==) . typeVisibility) types)
++ map (qname mod . funcName) (filter ((Public==) . funcVisibility) funcs)
++ map (identifier True . funcName) (filter ((Public==) . funcVisibility) funcs)
where
typeExpDoc tdecl =
let ecs = filter ((Public==) . consVisibility)
(trType (\_ _ _ cs -> cs) (\_ _ _ _ -> []) tdecl)
in qname mod (typeName tdecl) <> if null ecs then empty else text "(..)"
in identifier False (typeName tdecl) <> if null ecs then empty else text "(..)"
moduleHeaderDoc :: String -> [Doc] -> Doc
moduleHeaderDoc name exports
......@@ -122,11 +142,12 @@ opsDoc ops = vcat (map opDoc ops)
opDoc :: OpDecl -> Doc
opDoc (Op (_,name) fix prec)
= keyword "infix" <> fixDoc fix <+> int prec <+> operator (text name)
= keyword "infix" <> fixDoc fix <+> int prec <+> operator (inf (text name))
where
fixDoc InfixOp = empty
fixDoc InfixlOp = keyword "l"
fixDoc InfixrOp = keyword "r"
inf = if all (`elem` infixIDs) name then id else bquotes
typesDoc :: Bool -> String -> [TypeDecl] -> Doc
typesDoc isHs mod = vcat . map (typeDoc isHs mod)
......@@ -135,17 +156,17 @@ typesDoc isHs mod = vcat . map (typeDoc isHs mod)
typeDoc :: Bool -- generate instance declarations for Haskell?
-> String -> TypeDecl -> Doc
typeDoc True mod (Type name _ params cs)
= def (keyword "data" <+> qname mod name) params (consDeclsDoc mod cs <+> deriving) <$$>
= def (keyword "data" <+> identifier False name) params (consDeclsDoc mod cs <+> deriving) <$$>
(keyword "instance" <+> text "StrictCurry" <+> (if length params > 0 then parens else id)
(qname mod name <+> hsep (map varDoc params)) <+> keyword "where") <$>
(qname False name <+> hsep (map varDoc params)) <+> keyword "where") <$>
(text " " <+> keyword "underscore" <+> equals <+> (text (snd name ++ "Underscore"))) <$>
(text " " <+> keyword "showCons" <+> equals <+> (text ("showCons" ++ snd name)))
typeDoc False mod (Type name _ params cs)
= def (keyword "data" <+> qname mod name) params (consDeclsDoc mod cs)
= def (keyword "data" <+> identifier False name) params (consDeclsDoc mod cs)
typeDoc _ mod (TypeSyn name _ params syn)
= def (keyword "type" <+> qname mod name) params
= def (keyword "type" <+> identifier False name) params
(operator equals <+> typeExprDoc mod False syn)
varDoc :: Int -> Doc
......@@ -159,17 +180,17 @@ consDeclsDoc mod
consDeclDoc :: String -> ConsDecl -> Doc
consDeclDoc mod (Cons name _ _ args)
= app (qname mod name) (map (typeExprDoc mod True) args)
= app (identifier False name) (map (typeExprDoc mod True) args)
typeExprDoc :: String -> Bool -> TypeExpr -> Doc
typeExprDoc _ _ (TVar n) = varDoc n
typeExprDoc mod br (TCons name args)
| null args = qname mod name
| null args = qname False name
| name == (prelude,"[]") = brackets (typeExprDoc mod False (head args))
| isTupleName name = tupled (map (typeExprDoc mod False) args)
| otherwise
= par br $ app (qname mod name) (map (typeExprDoc mod True) args)
= par br $ app (qname False name) (map (typeExprDoc mod True) args)
typeExprDoc mod br typ@(FuncType _ _)
= par br $ fillEncloseSep empty empty (space<>arrow<>space)
......@@ -193,7 +214,7 @@ funcTypeDeclDoc mod name typ
inst = if null vars
then empty
else tupled (map ((text "StrictCurry" <+>) . varDoc) vars) <+> operator (text "=>") in
def (qname mod name) [] (funcTypeDoc inst mod (argTypes typ) (resultType typ))
def (identifier True name) [] (funcTypeDoc inst mod (argTypes typ) (resultType typ))
funcTypeDoc :: Doc -> String -> [TypeExpr] -> TypeExpr -> Doc
funcTypeDoc inst mod args res
......@@ -203,10 +224,10 @@ funcTypeDoc inst mod args res
ruleDoc :: String -> QName -> Rule -> Doc
ruleDoc mod name (Rule args body)
= def (qname mod name) args (equals <+> align (expDoc mod False body))
= def (identifier True name) args (equals <+> align (expDoc mod False body))
ruleDoc mod name (External _)
= qname mod name <+> keyword "external" -- <+> string decl
ruleDoc _ name (External _)
= identifier True name <+> keyword "external" -- <+> string decl
expDoc,expDoc2 :: String -> Bool -> Expr -> Doc
expDoc mod br exp =
......@@ -227,15 +248,14 @@ expDoc2 mod br (Comb ct name args)
| isInfixName name && length args == 2
= align $ fillEncloseSep lbr rbr empty
[expDoc mod True (args!!0)
,space <> operator (text (snd name)) <> space
,space <> qname' False False name <> space
,expDoc mod True (args!!1)]
-- = par br $ app (expDoc mod True (args!!0))
-- [text (snd name), expDoc mod True (args!!1)]
| otherwise
= par (not (null args) && br) $
app (qname mod name) (map (expDoc mod True) args)
app (qname (isFunCT ct) name) (map (expDoc mod True) args)
where
(lbr,rbr) = if br then (lparen,rparen) else (empty,empty)
expDoc2 mod br (Let bs e)
= par br $ hang 1 $
......@@ -248,7 +268,7 @@ expDoc2 mod br (Free vs e)
-- | otherwise
= par br $ hang 1 $
keyword "let" <+> align (fillSep (punctuate comma (map varDoc vs))) <+>
keyword "free" <$> keyword "in" <+> expDoc mod False e
keyword "=free" <$> keyword "in" <+> expDoc mod False e
expDoc2 mod br (FlatCurry.Or e1 e2)
= expDoc mod br (Comb FuncCall (prelude,"?") [e1,e2])
......@@ -260,23 +280,23 @@ expDoc2 mod br (Case ct e bs)
branchDoc :: String -> BranchExpr -> Doc
branchDoc mod (Branch pat e)
= def (patternDoc mod pat <+> arrow) [] (align (expDoc mod False e))
= def (patternDoc pat <+> arrow) [] (align (expDoc mod False e))
caseTypeDoc :: CaseType -> Doc
caseTypeDoc Rigid = empty
caseTypeDoc Flex = empty
patternDoc :: String -> Pattern -> Doc
patternDoc mod (Pattern name args)
| null args = qname mod name
patternDoc :: Pattern -> Doc
patternDoc (Pattern name args)
| null args = qname False name
| isTupleName name = tupled (map varDoc args)
| isInfixName name && length args == 2
= varDoc (args!!0) <> operator (text (snd name)) <> varDoc (args!!1)
{-| name == (prelude,":")
= varDoc (args!!0) <> operator colon <> varDoc (args!!1)-}
| otherwise = qname mod name <+> hsep (map varDoc args)
| otherwise = qname False name <+> hsep (map varDoc args)
patternDoc _ (LPattern l) = litDoc l
patternDoc (LPattern l) = litDoc l
letBindsDoc :: String -> [(Int,Expr)] -> Doc
letBindsDoc mod = align . compose (combine (linesep " ")) . map (letBindDoc mod)
......@@ -294,21 +314,21 @@ litDoc (Charc c) = literal (squotes (text (quoteChar c)))
quoteChar c = maybe [c] id (lookup c specialChars)
-- more?
specialChars = [('\\',"\\\\"),('\n',"\\n"),('\r',"\\r"),('\t',"\\t")]
specialChars = [('\\',"\\\\"),('\n',"\\n"),('\r',"\\r"),('\t',"\\t"),('\'',"\\'")]
toString :: Expr -> Maybe String
toString exp
= case exp of
Comb ConsCall ("Prelude","[]") [] -> Just ""
Comb ConsCall ("Prelude",":") [Lit (Charc c),cs] ->
Comb ConsCall (_,"[]") [] -> Just ""
Comb ConsCall (_,":") [Lit (Charc c),cs] ->
toString cs >>- Just . (quoteChar c++)
_ -> Nothing
toList :: Expr -> Maybe [Expr]
toList exp
= case exp of
Comb ConsCall ("Prelude","[]") [] -> Just []
Comb ConsCall ("Prelude",":") [x,xs] -> toList xs >>- Just . (x:)
Comb ConsCall (_,"[]") [] -> Just []
Comb ConsCall (_,":") [x,xs] -> toList xs >>- Just . (x:)
_ -> Nothing
-- introduces over-applications on purpose!
......@@ -322,13 +342,8 @@ elimApp = updCombs elim
| otherwise = Comb ct name args
extend (Comb ct name args) arg = Comb ct name (args++[arg])
-- testHtml name
-- = readFlatCurry name >>=
-- writeFile (name++".html") . showHtmlPage . HtmlPage name [] . (:[]) .
-- styledHtml . showStyledProg
-- Apply x y = Comb FuncCall ("Prelude","apply") [x,y]
-- test e = pretty 78 $ expDoc "" False $ e
isFunCT :: CombType -> Bool
isFunCT x = case x of
FuncCall -> True
FuncPartCall _ -> True
_ -> False
module StrictSteps(Oracle, Step, (>>>=), return',
module StrictSteps(Oracle, Step, (>>>=), return',
StrictCurry, showCons, underscore,
traceFunCall, traceProgram, traceWithStepfile,
ConstructorTerm, consTerm, consUnderscore,
......@@ -6,11 +6,18 @@ module StrictSteps(Oracle, Step, (>>>=), return',
) where
import Control.Monad.Error
import Monad (when)
import List (intersperse)
import Maybe (fromMaybe)
import Control.Monad.State
import Data.IORef
import System.Exit
import System.IO
hello= " ____ ____ _____ \n\
\( _ \\ (_ _) ( _ ) Believe\n\
\ ) _ < _)(_ )(_)( in\n\
\(____/()(____)()(_____)() Oracles\n\
\--------type ? for help----------"
{- ---------------------------------------------------------
BoolStack - eine Liste von Wahrheitswerten wird effizient
......@@ -21,10 +28,10 @@ import Data.IORef
type BoolStack = [Int]
emptyBoolStack :: BoolStack
emptyBoolStack = [0]
{-
eine (leider nur fast) unendliche Liste von True-Werten
-}
......@@ -59,7 +66,6 @@ pushBoolStack bs False = 0 : bs
data ConstructorTerm = ConsTerm String [ConstructorTerm]
| ConsUnderscore
| ConsAny
{-
......@@ -74,16 +80,12 @@ consUnderscore = ConsUnderscore
instance Show ConstructorTerm where
show ConsAny = "?"
show ConsUnderscore = "_"
show (ConsTerm name []) = name
show (ConsTerm name cs)
= '(' : name ++ ' ' : (unwords . map show) cs ++ ")"
instance Error ConstructorTerm where
noMsg = ConsAny
{-
Die Klasse der im Debugger beobachtbaren Datenstrukturen:
......@@ -100,7 +102,7 @@ class StrictCurry a where
-- Default-Implementierung
underscore = error "I stumbled over an underscore"
showCons _ = ConsAny
showCons _ = ConsUnderscore
instance StrictCurry (a -> b) where
......@@ -135,13 +137,21 @@ failed = undefined
type Oracle = BoolStack
{-
Anzeigemodus des Debuggers
-}
data DisplayMode = DisplayMode
{ verbose :: Bool, -- Ausfhrliche Statusmeldungen?
optionalResult:: Bool -- Inspizieren des Ergebnisses optional?
}
{-
Der Zustand eines Debuggers
-}
data DebuggerState = DebuggerState {
oracle :: Oracle, -- das aktuelle Orakel
displayMode :: IORef (Bool, -- Ausführliche Statusmeldungen?
Bool), -- Inspizieren des Ergebnisses optional?
displayMode :: IORef DisplayMode,
skipped :: BoolStack, -- welche Beurteilungen wurden in diesem
-- Durchlauf geskippt?
unrated :: BoolStack -- welche Funktionsaufrufe wurden bei den
......@@ -156,33 +166,35 @@ instance Show DebuggerState where
" unrated = " ++ show (unrated state) ++ "}"]
whenVerbose :: DebuggerState -> IO () -> IO ()
whenVerbose state action
= do (vbs, _) <- readIORef (displayMode state)
when vbs action
toggleVerbosity, toggleInspectMode :: DisplayMode -> DisplayMode
toggleVerbosity m
= m {verbose = not (verbose m)}
toggleInspectMode m
= m {optionalResult = not (optionalResult m)}
toggleVerbosity, toggleInspectMode :: DebuggerState -> IO ()
toggleVerbosity state
= modifyIORef (displayMode state) (\ (v, i) -> (not v, i))
getDisplayMode :: DebugMonad DisplayMode
getDisplayMode = do
state <- get
liftIO $ readIORef (displayMode state)
toggleInspectMode state
= modifyIORef (displayMode state) (\ (v, i) -> (v, not i))
modifyDisplayMode :: (DisplayMode -> DisplayMode) -> DebugMonad ()
modifyDisplayMode f = do
state <- get
liftIO $ modifyIORef (displayMode state) f
nextOracle :: DebuggerState -> (DebuggerState, Bool)
nextOracle state
= let (orc, strict) = popBoolStack (oracle state)
state' = state {oracle = orc}
in (state', strict)
popUnrated :: DebugMonad Bool
popUnrated = do
state <- get
let (ss, s) = popBoolStack (unrated state)
put $ state { unrated = ss }
return s
nextRating :: DebuggerState -> (DebuggerState, Bool)
nextRating state
= let (rest, first) = popBoolStack (unrated state)
state' = state { skipped = pushBoolStack (skipped state) first,
unrated = rest }
in (state', first)
pushSkipped :: Bool -> DebugMonad ()
pushSkipped b = modify (\s -> s { skipped = pushBoolStack (skipped s) b })
{-
......@@ -204,11 +216,28 @@ data StepMode = StepInteractive
deriving Eq
{-
BugReport - erklrt einen gefundenen Bug
-}
data BugReport = BugReport
{ lhs :: ConstructorTerm,
rhs :: ConstructorTerm }
{-
BugReport soll von der Monadentransformation
ErrorT verwendet werden, um Fehler zu melden.
-}
instance Error BugReport where
noMsg = BugReport
{ lhs = ConsUnderscore,
rhs = ConsUnderscore }
{-
Ein Berechnungsschritt ordnet einem Debugger-Zustand
entweder den Nachfolgezustand und das Ergebnis der
Auswertung (Left) oder den bei der interaktiven
Auswertung gefundenen Bug (Right) zu.
Auswertung oder den bei der interaktiven
Auswertung gefundenen Bug zu.
Bei der Berechnung werden
......@@ -219,9 +248,9 @@ data StepMode = StepInteractive
-}
type StepValue a = ErrorT ConstructorTerm IO (DebuggerState, a)
type DebugMonad a = StateT DebuggerState (ErrorT BugReport IO) a
type Step a = StepMode -> DebuggerState -> StepValue a
type Step a = StepMode -> DebugMonad a
......@@ -240,41 +269,61 @@ type Step a = StepMode -> DebuggerState -> StepValue a
(>>>=) :: StrictCurry a => (Step a) -> (a -> Step b) -> Step b
a >>>= b = \ mode state ->
let (s1, needed) = nextOracle state
applied (s, x) = b x mode s
in if needed then
a mode s1 >>= applied
else
b underscore mode s1
a >>>= b = \ mode -> do
a' <- evalIfNeeded a mode
b a' mode
return' :: StrictCurry a => a -> Step a
return' x _ s = return (s, x)
return' x = \ _ -> return x
evalIfNeeded :: StrictCurry a => Step a -> Step a
evalIfNeeded a mode
= do state <- get
let (orc, needed) = popBoolStack (oracle state)
put $ state {oracle = orc}
(if needed then
a mode
else
return underscore)
{- ---------------------------------------------------------
loadStepfile - eine Orakeldatei laden
traceProgram - ein instrumentiertes Programm debuggen
traceWithStepfile - eine Orakeldatei laden und ein
Programm mit dieser debuggen
loadStepfile - eine Orakeldatei laden
traceProgram - ein instrumentiertes Programm
mit einer bergebenen Orakelliste
debuggen
traceFunCall - einen Funktionsaufruf an den Debugger
melden
traceFunCall - einen Funktionsaufruf debuggen
--------------------------------------------------------- -}
traceWithStepfile :: StrictCurry a => String -> Step a -> IO ()
traceWithStepfile name program = do
hSetBuffering stdout NoBuffering
hSetBuffering stdin NoBuffering
-- hSetEcho stdin False -- this breaks ghci :-(
oracle <- loadStepfile name
let (l',_ ) = popBoolStack oracle
traceProgram (traceFunCall "main" [] program) l'
{-
loadStepfile laedt eine Orakelliste aus einer Datei
-}
traceWithStepfile :: StrictCurry a => String -> Step a -> IO ()
traceWithStepfile name program
loadStepfile :: String -> IO BoolStack
loadStepfile name
= let filename = name ++ ".steps"
in do file <- readFile filename
case reads file of
[(l,_)] -> let (l',_ ) = popBoolStack l
in traceProgram program l'
[(l,_)] -> return l
_ -> error $ "cannot load oracle file " ++ filename
......@@ -288,14 +337,14 @@ traceWithStepfile name program
traceProgram :: StrictCurry a => Step a -> Oracle -> IO ()
traceProgram program oracle
= do banner
vbs <- newIORef (False, True)
dmode <- newIORef (DisplayMode False True)
let state = DebuggerState
{oracle = oracle,
displayMode = vbs,
displayMode = dmode,
skipped = emptyBoolStack,
unrated = allTrue }
buggyRule <- runErrorT (traceLoop program state)
report buggyRule
bug <- runErrorT $ evalStateT (traceLoop program) state
report bug
{-
......@@ -303,14 +352,16 @@ traceProgram program oracle
darin alle Funktionsaufrufe bewertet sind oder ein
fehlerhafter Aufruf gefunden wurde.
-}
traceLoop :: StrictCurry a => Step a -> DebuggerState -> StepValue a
traceLoop program state
= do let startState = state { skipped = emptyBoolStack }
(endState,r) <- program StepInteractive startState
traceLoop :: StrictCurry a => Step a -> DebugMonad a
traceLoop program
= do state <- get
put $ state { skipped = emptyBoolStack }
r <- program StepInteractive
endState <- get
(if sum (skipped endState) == 0 then
return (endState, r)
else let restartState = state { unrated = reverse (skipped endState) }
in traceLoop program restartState)
return r
else do put $ state { unrated = reverse (skipped endState) }
traceLoop program)
{-
......@@ -319,54 +370,75 @@ traceLoop program state
traceFunCall ergnzt
-}
traceFunCall :: StrictCurry a => String -> [ConstructorTerm] -> Step a -> Step a
traceFunCall fname args expr stepMode callState
| stepMode == StepCorrect
= expr StepCorrect callState
| not isUnrated
= expr StepCorrect startState
| stepMode == StepBackground
= runInBackground
| otherwise -- StepInteractive
= d