Nice interpreter and pretty ICurry output, Arithmetic example added

Arithmetic.curry

+------------------------------------------------------------------------------
+-- 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

@@ -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

@@ -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

@@ -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

@@ -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 (graph 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 (graph st) argsenv evalcargs
+                (gr1,nexp) = extendGraph gr argsenv evalcargs
             in st { graph = either (error "Internal error in normalForm")
-                                   (updateNode g1 nid) nexp }
+                                   (updateNode gr1 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

@@ -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)
 
 ------------------------------------------------------------------------------