Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
curry-packages
icurry
Commits
08fb81a3
Commit
08fb81a3
authored
Jan 27, 2020
by
Michael Hanus
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Nice interpreter and pretty ICurry output, Arithmetic example added
parent
09fb28ea
Changes
6
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
107 additions
and
22 deletions
+107
-22
Arithmetic.curry
Arithmetic.curry
+51
-0
README.md
README.md
+1
-1
examples/InterpreterTests.curry
examples/InterpreterTests.curry
+4
-4
src/ICurry/Graph.curry
src/ICurry/Graph.curry
+13
-4
src/ICurry/Interpreter.curry
src/ICurry/Interpreter.curry
+35
-10
src/ICurry/Pretty.curry
src/ICurry/Pretty.curry
+3
-3
No files found.
Arithmetic.curry
0 → 100644
View file @
08fb81a3
------------------------------------------------------------------------------
-- Example with arithmetic computations to demonstrate the treatment
-- of external operations. Note that this works with the
-- ICurry interpreter in order to avoid the compilation
-- of the complete Curry prelude.
------------------------------------------------------------------------------
(+) :: Int -> Int -> Int
x + y = (prim_Int_plus $# y) $# x
-- The primitive addition `prim_Int_plus` is treated by the ICurry interpreter.
prim_Int_plus :: Int -> Int -> Int
prim_Int_plus external
(*) :: Int -> Int -> Int
x * y = (prim_Int_mult $# y) $# x
-- The primitive addition `prim_Int_mult` is treated by the ICurry interpreter.
prim_Int_mult :: Int -> Int -> Int
prim_Int_mult external
------------------------------------------------------------------------------
-- Combining arithmetic and non-determinism:
coin :: Int
coin = 0
coin = 1
coinCoin = coin + coin
double :: Int -> Int
double x = x + x
doubleCoin = double coin
------------------------------------------------------------------------------
-- Higher-order with arithmetic operations.
map :: (a -> b) -> [a] -> [b]
map _ [] = []
map f (x : xs) = f x : map f xs
inc123 :: [Int]
inc123 = normalForm (map (1+) [1,2,3])
foldr :: (a -> b -> b) -> b -> [a] -> b
foldr _ z [] = z
foldr f z (x:xs) = f x (foldr f z xs)
fac5 :: Int
fac5 = foldr (*) 1 [1,2,3,4,5]
------------------------------------------------------------------------------
README.md
View file @
08fb81a3
...
...
@@ -93,6 +93,6 @@ one can wrap it with the function `normalForm`, e.g.,
mymain = normalForm (reverse [1,2,3])
The current version of the interpreter supports only the prelude
operations
`normalForm`
and
`$!`
.
operations
`normalForm`
,
`$#`
,
and
`$!`
.
----------------------------------------------------------------------------
examples/InterpreterTests.curry
View file @
08fb81a3
...
...
@@ -349,17 +349,17 @@ testIdTrue :: Prop
testIdTrue = evalFunND exampleProg "idTrue" <~> "True"
testCoinList :: Prop
testCoinList = evalFunND exampleProg "coinList" <~> ("(
: 1
[])" ? "(
: 2
[])")
testCoinList = evalFunND exampleProg "coinList" <~> ("(
1 :
[])" ? "(
2 :
[])")
testCoinCoinList :: Prop
testCoinCoinList =
evalFunND exampleProg "coinCoinList" <~>
("(
:
1
(
:
1
[]))" ? "(
:
2
(
:
1
[]))" ? "(
:
1
(
:
2
[]))" ? "(
:
2
(
:
2
[]))")
("(1 :
(1 :
[]))" ? "(2 :
(1 :
[]))" ? "(1 :
(2 :
[]))" ? "(2 :
(2 :
[]))")
testPerm123 :: Prop
testPerm123 =
evalFunND exampleProg "perm123" <~>
("(
:
1
(
: 2
(
: 3 [])))" ? "(
:
1
(
: 3
(
:
2
[])))" ? "(
:
2
(
: 1
(
:
3
[])))" ?
"(
:
2
(
: 3
(
: 1 [])))" ? "(
:
3
(
: 1
(
:
2
[])))" ? "(
:
3
(
: 2
(
:
1
[])))")
("(1 :
(
2 :
(
3
:
[])))" ? "(1 :
(
3 :
(2 :
[])))" ? "(2 :
(
1 :
(3 :
[])))" ?
"(2 :
(
3 :
(
1
:
[])))" ? "(3 :
(
1 :
(2 :
[])))" ? "(3 :
(
2 :
(1 :
[])))")
------------------------------------------------------------------------------
src/ICurry/Graph.curry
View file @
08fb81a3
...
...
@@ -132,7 +132,7 @@ replaceNode (Graph nodes mx) oldnid newid =
-- Shows the expression represented by the graph starting with a given node.
-- In order to visualize sharing, shared subexpressions are shown
--
by
let expressions.
--
as
let expressions.
showGraphExp :: Graph -> NodeID -> String
showGraphExp g nid = showExp [] 10 nid
where
...
...
@@ -150,11 +150,20 @@ showGraphExp g nid = showExp [] 10 nid
then ""
else "let {" ++
intercalate " ; " (map showLetDecl arglets) ++ "} in ") ++
unwords (f :
map (\a -> if a `elem` alllets
then showVar a
else showExp alllets (d-1) a) args) ++
showCall f (
map (\a -> if a `elem` alllets
then showVar a
else showExp alllets (d-1) a) args) ++
")"
where
showCall f args =
if isInfixOp f
then case args of
[a1,a2] -> unwords [a1,f,a2]
_ -> unwords (('(' : f ++ ")") : args)
else unwords (f : args)
where
isInfixOp = all (`elem` "!@#$%^&*+-=<>?./|\\:")
arglets = nub (concatMap
(\a -> let occs = occursInGraphExp d a ni
in if occs < 2 || isConst a then [] else [a])
...
...
src/ICurry/Interpreter.curry
View file @
08fb81a3
...
...
@@ -333,32 +333,52 @@ evalFirstTask st (Task (IBlockEnv (IBlock vs asgns stm) ienv) stk fp : tsks) =
invokeFunction :: State -> [Task] -> State
invokeFunction _ [] = error "invokeFunction: empty tasks"
invokeFunction st (Task (CNode nid) stk fp : tsks) =
case lookupNode nid
(
gr
aph st)
of
case lookupNode nid gr of
FuncNode f ns -> case bodyOf f (program st) of
IFuncBody blck ->
let ienv = [(0, nid)]
in st { tasks = Task (IBlockEnv blck ienv) stk fp : tsks }
IExternal en -> case en of
"apply" ->
let node = addPartialArg (lookupNode (ns!!0) (graph st)) (ns!!1)
in st { graph = updateNode (graph st) nid node }
"$!" -> st { graph = updateNode (graph st) nid (FuncNode "apply" ns) }
"normalForm" -> case lookupNode (ns!!0) (graph st) of
"normalForm" -> case lookupNode (ns!!0) gr of
ConsNode c cargs ->
let argsenv = zip [1..] cargs
evalcargs = foldl (\xs x -> IFCall ("","$!",0)
[xs, IFCall ("","normalForm",0)
[IVar (fst x)]])
(ICPCall ("",c,0) (length cargs) []) argsenv
(g1,nexp) = extendGraph
(
gr
aph st)
argsenv evalcargs
(g
r
1,nexp) = extendGraph gr argsenv evalcargs
in st { graph = either (error "Internal error in normalForm")
(updateNode g1 nid) nexp }
(updateNode g
r
1 nid) nexp }
_ -> error "step: use of 'normalForm' without constructor argument"
_
-> error $ "step: unknown external function: " ++ en
_
-> st { graph = updateNode gr nid (evalExternal gr en ns) }
_ -> error "invokeFunction: no function node in control"
where gr = graph st
invokeFunction _ (Task (IBlockEnv _ _) _ _ : _) =
error "invokeFunction: no function node in control"
-- Evaluates an external function to a node containing the evaluated value.
-- The arguments are the current graph, the external name,
-- and the argument nodes.
evalExternal :: Graph -> String -> [NodeID] -> Node
evalExternal gr ename ns = case unQName ename of
"apply" -> addPartialArg (lookupNode (ns!!0) gr) (ns!!1)
"$!" -> FuncNode "apply" ns
"$#" -> FuncNode "apply" ns
"prim_Int_plus" ->
ConsNode (show (lookupIntNode (ns!!0) gr + lookupIntNode (ns!!1) gr)) []
"prim_Int_mult" ->
ConsNode (show (lookupIntNode (ns!!0) gr * lookupIntNode (ns!!1) gr)) []
_ -> error $ "step: unknown external function: " ++ ename
where
unQName s = let (mn,ufn) = break (=='.') s
in if null ufn then mn else unQName (tail ufn)
lookupIntNode :: NodeID -> Graph -> Int
lookupIntNode nid gr = case lookupNode nid gr of
ConsNode c [] -> read c :: Int
_ -> error "lookupIntNode: no integer found"
-- Selects the constructor branch corresponding to some constructor node.
selectConsBranch :: Node -> [IConsBranch] -> IBlock
selectConsBranch nd [] =
...
...
@@ -493,12 +513,17 @@ funSeq = IFunction ("Prelude","seq",0) 2 Public [0] $ IFuncBody $
funDollarBang :: IFunction
funDollarBang = IFunction ("Prelude","$!",0) 2 Public [1] (IExternal "$!")
-- f $# x: demands x and returns (f x) (and suspends on a free variable
-- which is not yet implemented)
funDollarHash :: IFunction
funDollarHash = IFunction ("Prelude","$#",0) 2 Public [1] (IExternal "$#")
-- normalForm x: demands x and returns the normal form of x
funNormalForm :: IFunction
funNormalForm =
IFunction ("Prelude","normalForm",0) 1 Public [0] (IExternal "normalForm")
standardFuncs :: [IFunction]
standardFuncs = [funApply, funSeq, funDollarBang, funNormalForm]
standardFuncs = [funApply, funSeq, funDollarBang,
funDollarHash,
funNormalForm]
------------------------------------------------------------------------------
src/ICurry/Pretty.curry
View file @
08fb81a3
...
...
@@ -205,8 +205,8 @@ ppPos pos = text (show pos)
--- @param lit the literal
--- @return the pretty printed literal
ppLit :: ILiteral -> Doc
ppLit (IInt
v
) = int
v
ppLit (IFloat
v
) = float
v
ppLit (IChar
v
) =
char v
ppLit (IInt
i
) = int
i
ppLit (IFloat
f
) = float
f
ppLit (IChar
c
) =
text (show c)
------------------------------------------------------------------------------
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment