Commit a244757d authored by bbr's avatar bbr
Browse files

initial checkin of oracle debugger

the files are taken from subversion repository
parent 2931cbef
# Makefile for main module "Curry2StrictPl":
PAKCSHOME=/home/pakcs/pakcs
PAKCSLIB=${PAKCSHOME}/lib
.PHONY: all
all: Curry2StrictPl.state SourceProgGUI.state Oracle.fcy
Curry2StrictPl.state:Curry2StrictPl.curry \
Prolog.curry \
ReadFlat.curry \
${PAKCSLIB}/Integer.curry \
${PAKCSLIB}/ReadShowTerm.curry \
${PAKCSLIB}/meta/CompactFlatCurry.curry \
${PAKCSLIB}/PropertyFile.curry \
${PAKCSLIB}/Distribution.curry \
${PAKCSLIB}/FileGoodies.curry \
${PAKCSLIB}/meta/FlatCurry.curry \
${PAKCSLIB}/SetRBT.curry \
${PAKCSLIB}/Sort.curry \
${PAKCSLIB}/TableRBT.curry \
${PAKCSLIB}/Time.curry \
${PAKCSLIB}/XML.curry \
${PAKCSLIB}/Directory.curry \
${PAKCSLIB}/IOExts.curry \
${PAKCSLIB}/Maybe.curry \
${PAKCSLIB}/RedBlackTree.curry \
${PAKCSLIB}/List.curry \
${PAKCSLIB}/Read.curry \
${PAKCSLIB}/IO.curry \
${PAKCSLIB}/System.curry \
${PAKCSLIB}/Char.curry
# create saved state for top-level function "main":
${PAKCSHOME}/bin/pakcs -s Curry2StrictPl
rm -f debug ; ln -s Curry2StrictPl.state debug
SourceProgGUI.state:SourceProgGUI.curry ${PAKCSLIB}/GUI.curry
${PAKCSHOME}/bin/pakcs -s SourceProgGUI
Oracle.fcy: Oracle.curry \
${PAKCSLIB}/IOExts.curry \
${PAKCSLIB}/Unsafe.curry \
${PAKCSLIB}/IO.curry \
${PAKCSLIB}/System.curry \
${PAKCSLIB}/Char.curry
# compile Oracle to create current .fcy file
${PAKCSHOME}/bin/pakcs -c Oracle
.PHONY: clean
clean:
${PAKCSHOME}/bin/cleancurry
rm -f debug
rm -f ?*Oracle.fcy ?*Oracle.pl ?*Oracle.po *s.pl *.steps
stricths: stricths.curry PrettyStrict.curry
kics -executable -o stricths stricths.curry
transform.bin: Transform.curry ReadFlat.curry Wrapper.curry
kics -executable -o transform.bin Transform.curry
--- Provides the interface that is used to generate and send events.
---
--- @version Feb, 2007
---
module Oracle where
import IOExts
import Unsafe
infixr 0 $!, $!!, $#, $##
type Ref = IORef Node
data Node = Node Ref Cost Ref | Marker | Collapsed
type Cost = Int
--- Wrapper for constructor with one missing argument.
partCons :: (a -> b) -> Ref -> a -> b
partCons c r x = collapse r (c x)
-- partCons c r = collapse r c
--- Wrapper for function with one missing argument.
partFunc :: (a -> Ref -> b) -> Ref -> a -> b
partFunc f r x = replace r (f x r)
-- partFunc f r = replace r (\x -> f x r)
--- Wrapper for call with more than one missing argument.
partCall :: a -> Ref -> a
partCall x r = collapse r x
--- Wrapper for apply function.
apply :: (Ref -> a -> b) -> a -> Ref -> b
apply f x r = f r x
--- Wrapper for hnf apply function.
($!) :: (Ref -> a -> b) -> a -> Ref -> b
($!) f x r = f r Prelude.$! x
--- Wrapper for nf apply function.
($!!) :: (Ref -> a -> b) -> a -> Ref -> b
($!!) f x r = f r Prelude.$!! x
--- Wrapper for ghnf apply function.
($#) :: (Ref -> a -> b) -> a -> Ref -> b
($#) f x r = f r Prelude.$# x
--- Wrapper for gnf apply function.
($##) :: (Ref -> a -> b) -> a -> Ref -> b
($##) f x r = f r Prelude.$## x
--- Function composition (Prelude version may be transformed)
compose :: (b -> c) -> (a -> b) -> a -> c
compose f g x = f (g x)
--- Computes the oracle for a computation.
oracle :: String -> (Ref -> a) -> ()
oracle mod app = unsafePerformIO $ do
startMarker <- newIORef (error "startMarker")
endMarker <- newIORef (error "endMarker")
mainR <- newIORef (Node startMarker 0 endMarker)
marker <- newIORef Marker
writeIORef startMarker (Node marker 0 mainR)
writeIORef endMarker (Node mainR 0 marker)
x <- return Prelude.$!! app mainR
finalize mod startMarker endMarker
-- return x
--- Signals the end of the computation.
finalize :: String -> Ref -> Ref -> IO ()
finalize mod fmR endR = do
_:l <- pointerToList fmR endR
writeFile (mod++".steps") (show l ++ "\n.\n")
--- Side effect that computes a fresh reference.
fresh :: () -> Ref -- must not be a constant in Haskell
fresh _ = unsafePerformIO $ do
newIORef (error "fresh")
--- increase couter of ref by one
replace :: Ref -> a -> a
replace ref x = unsafePerformIO $ do
node <- readIORef ref
case node of
Collapsed -> warning "tried to replace collapsed ref"
Node p c s -> writeIORef ref (Node p (c+1) s)
return x
--- Remove a ref and combine and counter +1
collapse :: Ref -> a -> a
collapse ref x = unsafePerformIO $ do
node <- readIORef ref
case node of
Collapsed -> warning "tried to collapse collapsed ref"
Node p c s -> do
Node pp pc _ <- readIORef p
Node _ sc ss <- readIORef s
writeIORef ref Collapsed
writeIORef p (Node pp pc s)
writeIORef s (Node p (c+1+sc) ss)
return x
--- Projection on last argument that releases an event as a side effect.
-- increment step counter of first ref and add remaining refs
-- list has to be at least of size 1
expand :: Ref -> [Ref] -> a -> a
expand ref refs x = unsafePerformIO $ do
node <- readIORef ref
case node of
Collapsed -> warning "tried to expand collapsed ref"
Node p c s -> do
last <- toAssocList (c+1) p (ref:refs) s
suc <- readIORef s
case suc of
Collapsed -> warning "successor of expanded ref is already collapsed"
Node _ sc ss -> writeIORef s (Node last sc ss)
Marker -> done
return x
toAssocList :: Cost -> Ref -> [Ref] -> Ref -> IO Ref
toAssocList c p [r] s = writeIORef r (Node p c s) >> return r
toAssocList c p (r:rs@(r':_)) s = do
writeIORef r (Node p c r')
toAssocList 0 r rs s
pointerToList :: Ref -> Ref -> IO [Cost]
pointerToList ref end = do
node <- readIORef ref
case node of
Collapsed -> warning "final list contains collapsed reference" >> return []
Node _ c s -> do
cs <- pointerToList s end
return (c:cs)
Marker -> return []
warning :: String -> IO ()
warning msg = putStrLn $ "WARNING: " ++ msg
{-
main = initialize f
f :: State -> Ref -> Int
f st n = expand st 0 [1,2]
expand st 2 [3,4]
expand st 1 [5]
expand st 5 []
-- (finalize st 42)
-}
bla = do
x <- newIORef 1
print x
y <- newIORef 1
return (x==y)
\ No newline at end of file
module Parser where
infixl 2 `opt`
infixl 3 <|>, <||>
infixl 4 <$>, <$, <*>, *>, <*, <**>, <??>, <->>
type Parser s a = [s] -> [(a,[s])]
parse :: Parser s a -> [s] -> a
parse p s = fst . head $ filter (null . snd) (p s)
pSucceed :: a -> Parser s a
pSucceed v = (\ts -> [(v,ts)])
pFail :: Parser s a
pFail = (\_ -> [])
pPred :: (s -> Bool) -> Parser s s
pPred pred = p
where
p [] = []
p (t:ts)
| pred t = [(t,ts)]
| otherwise = []
pSym :: s -> Parser s s
pSym t = pPred (t==)
pAnyOf :: [s] -> Parser s s
pAnyOf = foldr (<|>) pFail . map pSym
opt :: Parser s a -> a -> Parser s a
p `opt` x = p <|> pSucceed x
(<|>) :: Parser s a -> Parser s a -> Parser s a
p <|> q = (\ts -> p ts ++ q ts)
(<||>) :: Parser s a -> Parser s a -> Parser s a
p <||> q = (\ts -> let res = p ts in if null res then q ts else res)
(<*>) :: Parser s (a -> b) -> Parser s a -> Parser s b
p <*> q = (\ts -> [ (f x,ts2) | (f,ts1) <- p ts, (x,ts2) <- q ts1 ])
(<$>) :: (a -> b) -> Parser s a -> Parser s b
f <$> p = pSucceed f <*> p
(<$) :: a -> Parser s b -> Parser s a
f <$ p = const f <$> p
(*>) :: Parser s a -> Parser s b -> Parser s b
p *> q = const id <$> p <*> q
(<*) :: Parser s a -> Parser s b -> Parser s a
p <* q = flip (const id) <$> p <*> q
(<**>) :: Parser s a -> Parser s (a -> b) -> Parser s b
p <**> q = flip ($) <$> p <*> q
(<??>) :: Parser s a -> Parser s (a->a) -> Parser s a
p <??> q = p <**> (q `opt` id)
pFoldr :: (a -> b -> b) -> b -> Parser s a -> Parser s b
pFoldr op e p = q where q = (op <$> p <*> q) `opt` e
pFoldrSep :: (a -> b -> b) -> b -> Parser s c -> Parser s a -> Parser s b
pFoldrSep op e sep p = (op <$> p <*> pFoldr op e (sep *> p)) `opt` e
pList :: Parser s a -> Parser s [a]
pList = pFoldr (:) []
pListSep :: Parser s a -> Parser s b -> Parser s [b]
pListSep = pFoldrSep (:) []
pSome :: Parser s a -> Parser s [a]
pSome p = (:) <$> p <*> pList p
(<->>) :: Parser s a -> (a -> Parser s b) -> Parser s b
p <->> f = (\ts -> [ res | (x,ts') <- p ts, res <- f x ts' ])
check :: (a -> Bool) -> Parser s a -> Parser s a
check pred (p) = (\ts -> filter (pred . fst) (p ts))
pAB = pSucceed 0 <|> pSym 'a' *> pAB <* pSym 'b'
main = parse pAB "aabb"
module PrettyStrict where
import Char
import Maybe
import Pretty
import FlatCurry
import FlatCurryGoodies
import StyledText
import List (nub)
prelude = "Prelude"
arrow = operator (text "->")
bind = operator (text ">>>=")
bar = operator (char '|')
dcolon = operator (text "::")
deriving = text "deriving Show"
isInfixName :: QName -> Bool
isInfixName (_,n) = all (`elem` infixIDs) n
infixIDs :: String
infixIDs = "~!@#$%^&*+-=<>?./|\\:"
isTupleName :: QName -> Bool
isTupleName (mod,name) = mod == prelude && elem (take 2 name) ["()","(,"]
showStyledProg :: Bool -> Prog -> String
showStyledProg isHs = pretty 78 . progDoc isHs . updProgExps elimApp
showProg :: Bool -> Prog -> String
showProg isHs = plainText . showStyledProg isHs
printStyledProg :: Bool -> String -> IO ()
printStyledProg isHs f = readFlatCurry f >>= printStyledText . showStyledProg isHs
printProg :: Bool -> String -> IO ()
printProg isHs f = readFlatCurry f >>= putStrLn . showProg isHs
-- viewStyledProg :: WidgetRef -> Prog -> GuiPort -> IO ()
-- viewStyledProg ref prog = setStyledText ref (showStyledProg prog)
--viewProg :: Bool -> WidgetRef -> Prog -> GuiPort -> IO ()
--viewProg isHs ref prog = setValue ref (showProg isHs prog)
keyword, consname :: String -> Doc
keyword = magentaDoc . text
consname = greenDoc . text
operator, literal, marked :: Doc -> Doc
operator = blueDoc
literal = cyanDoc
marked = bgYellowDoc . boldDoc
block :: Doc -> Doc
block = group . hang 1
def :: Doc -> [Int] -> Doc -> Doc
def name params body = block (name <> paramDoc <$> body)
where
paramDoc = if null params then empty
else space <> align (fillSep (map varDoc params))
{-
fillMulti :: (Doc -> Doc) -> (Doc -> Doc) -> [Doc] -> Doc
fillMulti _ _ [] = empty
fillMulti x y (d:ds)
= align (fillSep ((x d) : map (group . (linebreak<>) . y) ds))
-}
app :: Doc -> [Doc] -> Doc
app d ds = if null ds then d
else block (fillEncloseSep empty empty space (d:ds))
--else block (d <$> fillEncloseSep empty empty space ds)
--else block (d <$> fillMulti (empty<>) (empty<>) ds)
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)
d1 <$>> d2 = d1 <$> line <> d2
progDoc :: Bool -> Prog -> Doc
progDoc isHs prog@(Prog name imps types funcs ops)
= moduleHeaderDoc name (exportedNames name prog) <$>>
impsDoc imps <$>> opsDoc ops <$>>
typesDoc isHs name types <$>>
funcsDoc name funcs
exportedNames :: String -> Prog -> [Doc]
exportedNames mod (Prog _ _ types funcs _)
= map typeExpDoc (filter ((Public==) . typeVisibility) types)
++ map (qname mod . 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 "(..)"
moduleHeaderDoc :: String -> [Doc] -> Doc
moduleHeaderDoc name exports
= keyword "module" <+> consname name <+> exportsDoc exports <+>
keyword "where"
exportsDoc :: [Doc] -> Doc
exportsDoc xs
= group (nest 1 (lparen <$> align (fillSep (punctuate comma xs)) <$> rparen))
impsDoc :: [String] -> Doc
impsDoc imps = vcat (map ((keyword "import" <+>) . consname) imps)
opsDoc :: [OpDecl] -> Doc
opsDoc ops = vcat (map opDoc ops)
opDoc :: OpDecl -> Doc
opDoc (Op (_,name) fix prec)
= keyword "infix" <> fixDoc fix <+> int prec <+> operator (text name)
where
fixDoc InfixOp = empty
fixDoc InfixlOp = keyword "l"
fixDoc InfixrOp = keyword "r"
typesDoc :: Bool -> String -> [TypeDecl] -> Doc
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) <$$>
(keyword "instance" <+> text "StrictCurry" <+> (if length params > 0 then parens else id)
(qname mod 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)
typeDoc _ mod (TypeSyn name _ params syn)
= def (keyword "type" <+> qname mod name) params
(operator equals <+> typeExprDoc mod False syn)
varDoc :: Int -> Doc
varDoc = text . ('x':) . show
consDeclsDoc :: String -> [ConsDecl] -> Doc
consDeclsDoc mod
= fillEncloseSep (operator equals<>space) empty (bar<>space)
. map ((<>space) . consDeclDoc mod)
--= fillMulti (equals<+>) (bar<+>) . map (consDeclDoc mod)
consDeclDoc :: String -> ConsDecl -> Doc
consDeclDoc mod (Cons name _ _ args)
= app (qname mod 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
| 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)
typeExprDoc mod br typ@(FuncType _ _)
= par br $ fillEncloseSep empty empty (space<>arrow<>space)
--fillMulti (empty<>) (arrow<+>)
(map (typeExprDoc mod True) (argTypes typ) ++
[typeExprDoc mod False (resultType typ)])
par br = if br then parens else id
funcsDoc :: String -> [FuncDecl] -> Doc
funcsDoc mod funcs = vcat (punctuate line (map (funcDoc mod) funcs))
funcDoc :: String -> FuncDecl -> Doc
funcDoc mod (Func name _ _ typ rule)
= funcTypeDeclDoc mod name typ <$>
ruleDoc mod name rule
funcTypeDeclDoc :: String -> QName -> TypeExpr -> Doc
funcTypeDeclDoc mod name typ
= let vars = nub $ allVarsInTypeExpr 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))
funcTypeDoc :: Doc -> String -> [TypeExpr] -> TypeExpr -> Doc
funcTypeDoc inst mod args res
= fillEncloseSep ((dcolon <+> inst)<>space) empty (arrow<>space)
--= fillMulti (dcolon<+>) (arrow<+>)
(map ((<>space) . typeExprDoc mod True) (args++[res]))
ruleDoc :: String -> QName -> Rule -> Doc
ruleDoc mod name (Rule args body)
= def (qname mod name) args (equals <+> align (expDoc mod False body))
ruleDoc mod name (External _)
= qname mod name <+> keyword "external" -- <+> string decl
expDoc,expDoc2 :: String -> Bool -> Expr -> Doc
expDoc mod br exp =
maybe (maybe (expDoc2 mod br exp)
(\l -> list (map (expDoc mod False) l))
(toList exp))
(\s -> if null s then consname "[]" else literal (dquotes (text s)))
(toString exp)
expDoc2 _ _ (Var n) = varDoc n
expDoc2 _ _ (Lit l) = litDoc l
expDoc2 mod br (Comb ct name args)
| ct == FuncCall && name == (prelude,"apply")
= par br $ app (expDoc mod True (args!!0)) [expDoc mod True (args!!1)]
| ct == ConsCall && isTupleName name
= tupled (map (expDoc mod False) args)
| isInfixName name && length args == 2
= align $ fillEncloseSep lbr rbr empty
[expDoc mod True (args!!0)
,space <> operator (text (snd 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)
where
(lbr,rbr) = if br then (lparen,rparen) else (empty,empty)
expDoc2 mod br (Let bs e)
= par br $ hang 1 $
letBindsDoc mod bs <$>
expDoc mod False e
expDoc2 mod br (Free vs e)
-- | null vs = marked (expDoc mod br e)
-- | any (<0) vs = expDoc mod br e
-- | otherwise
= par br $ hang 1 $
keyword "let" <+> align (fillSep (punctuate comma (map varDoc vs))) <+>
keyword "free" <$> keyword "in" <+> expDoc mod False e
expDoc2 mod br (FlatCurry.Or e1 e2)
= expDoc mod br (Comb FuncCall (prelude,"?") [e1,e2])
expDoc2 mod br (Case ct e bs)
= par br $ hang 1 $
caseTypeDoc ct <> keyword "case" <+> align (expDoc mod False e) <+>
keyword "of" <$> layout (map (branchDoc mod) bs)
branchDoc :: String -> BranchExpr -> Doc
branchDoc mod (Branch pat e)
= def (patternDoc mod 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
| 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)
patternDoc _ (LPattern l) = litDoc l
letBindsDoc :: String -> [(Int,Expr)] -> Doc
letBindsDoc mod = align . compose (combine (linesep " ")) . map (letBindDoc mod)
letBindDoc :: String -> (Int,Expr) -> Doc
letBindDoc mod (n,e) =
expDoc mod False e <+>
bind <+> backslash <+> varDoc n <+> arrow
litDoc :: Literal -> Doc
litDoc (Intc n) = literal (int n)
litDoc (Floatc x) = literal (float x)
litDoc (Charc c) = literal (squotes (text (quoteChar c)))
quoteChar c = maybe [c] id (lookup c specialChars)
-- more?
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] ->
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:)
_ -> Nothing
-- introduces over-applications on purpose!
elimApp :: Expr -> Expr
elimApp = updCombs elim
where
elim ct name args
| ct == FuncCall && name == (prelude,"apply") && isComb (head args) &&
combName (head args) /= (prelude,"apply")
= extend (head args) (args!!1)
| 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
------------------------------------------------------------------------------
--- A library containing a representation for Prolog programs together
--- with a simple pretty printer.
---
--- @author Michael Hanus
--- @version February 13, 2007
------------------------------------------------------------------------------
module Prolog(PlClause(..),PlGoal(..),PlTerm(..),showPlProg) where
import Char(isAlphaNum,isLower)
import List(union,intersperse)
----------------------------------------------------------------------------
-- Representation of Prolog programs: