diff --git a/Data/Number/Sifflet.hs b/Data/Number/Sifflet.hs new file mode 100644 --- /dev/null +++ b/Data/Number/Sifflet.hs @@ -0,0 +1,271 @@ +-- | This module provides the Sifflet Number type and many operations upon it. +-- Most of the operations are provided by making Number an instance +-- of the classes Num, Real, Enum, Integral, Fractional, Floating, +-- and RealFrac. These are, I think, all of the normal Haskell +-- numeric type classes *except* RealFloat. +-- There are also a few functions defined in addition to the +-- class methods. +-- +-- The *primary* purpose of this module is to be the library module +-- used by Sifflet programs exported to Haskell. +-- The *secondary* purpose (maybe no less important, but +-- realized after the first) is to implement the Sifflet +-- number Values (previously done with the VInt and VFloat constructors). + +module Data.Number.Sifflet + ( + Number(..) + , isExact, toInexact + , add1, sub1, eqZero, gtZero, ltZero + ) + +where + +-- | A Number represents a real number, which can be exact (Integer) +-- or inexact (Double). + +data Number = Exact Integer | Inexact Double + deriving (Eq, Read) + +-- | Tell whether a Number is exact +isExact :: Number -> Bool +isExact (Exact _) = True +isExact _ = False + +-- | Take a number, which may be exact or inexact, and +-- produce the inexact number which equals it. +-- Note that there is no inverse function toExact, +-- because some inexact numbers like 3.5 are not equal to any exact number. +-- The class RealFrac provides methods round, ceiling, floor, truncate +-- for converting to exact numbers. + +toInexact :: Number -> Number +toInexact (Exact x) = Inexact (fromIntegral x) +toInexact xx = xx + +toDouble :: Number -> Double +toDouble (Exact ix) = fromIntegral ix +toDouble (Inexact rx) = rx + +-- | Unary operations fall into two groups: +-- exactOp1 works only for an exact operand; +-- it is an error if the operand is inexact. +-- The result is always exact. +-- (Unused) +-- inexactOp1 works directly for an inexact operand; +-- otherwise by conversion of its exact operand to inexact; +-- the result is always inexact. +-- eitherOp1 works for either exact or inexact operand, +-- and the result is exact if and only if the operand is exact. + +exactOp1 :: String -> (Integer -> Integer) -> (Number -> Number) +exactOp1 name f x = + case x of + Exact i -> Exact (f i) + _ -> error ("Number:" ++ name ++ ": inexact operand: " ++ show x) + +inexactOp1 :: (Double -> Double) -> (Number -> Number) +-- inexactOp1 f x = Inexact (f (toDouble x)) +inexactOp1 f = Inexact . f . toDouble + +eitherOp1 :: (Integer -> Integer) -> (Double -> Double) + -> (Number -> Number) +eitherOp1 fi fr arg = + case arg of + Exact i -> Exact (fi i) + Inexact r -> Inexact (fr r) + +-- | Binary operations fall in 3 groups: +-- exactOp2 is implemented only for exact, exact operands; +-- if there's any inexact operand, it's an error. +-- Integer division operations (quot, rem, div, mod) +-- are like this. The result is always exact. +-- eitherOp2 is implemented directly for exact, exact operands +-- and inexact, inexact operands; if one operand is +-- exact and the other inexact, the exact operand +-- is converted to inexact. Most arithmetic operations +-- (+, -, *) are like this. The result may be exact or inexact. +-- inexactop2 is directly implemented for inexact, inexact operands, +-- but handles exact operands by converting them to inexact +-- (even if both are exact). Math functions such as +-- exp, log, sqrt, and sin are like this. The result +-- is always inexact. + +exactOp2 :: String -> (Integer -> Integer -> Integer) + -> (Number -> Number -> Number) + +exactOp2 _ f (Exact i) (Exact j) = Exact (f i j) +exactOp2 name _ x y = + error ("Number:" ++ name ++ ": inexact operand(s): " ++ + show x ++ ", " ++ show y) + +inexactOp2 :: (Double -> Double -> Double) + -> (Number -> Number -> Number) + +inexactOp2 f x y = Inexact (f (toDouble x) (toDouble y)) + + +eitherOp2 :: (Integer -> Integer -> Integer) + -> (Double -> Double -> Double) + -> (Number -> Number -> Number) + +eitherOp2 fi _ (Exact i) (Exact j) = Exact (fi i j) +eitherOp2 _ fx x y = Inexact (fx (toDouble x) (toDouble y)) + + +-- | This Show instance will not be compatible with the +-- derived Read instance above -- so fix it. +-- (And yet, mysteriously, ghci accepts 1 and 1.0 as Number literals.) + +instance Show Number where + show (Exact i) = show i + show (Inexact x) = show x + +-- | Number as an ordered type +instance Ord Number where + compare (Exact x) (Exact y) = compare x y + compare (Inexact x) (Inexact y) = compare x y + compare (Exact x) (Inexact y) = compare (fromIntegral x) y + compare (Inexact x) (Exact y) = compare x (fromIntegral y) + -- This could take the place of the previous two: + -- compare mx my = compare (toInexact mx) (toInexact my) + +-- | Number as an instance of Num +instance Num Number where + (+) = eitherOp2 (+) (+) + (-) = eitherOp2 (-) (-) + (*) = eitherOp2 (*) (*) + + negate = eitherOp1 negate negate + abs = eitherOp1 abs abs + signum = eitherOp1 signum signum + + fromInteger = Exact + +-- | Numbers are Real, i.e., can be converted to Rational +instance Real Number where + toRational (Exact i) = toRational i + toRational (Inexact x) = toRational x + +-- | In Haskell both Intgeger and Double are instances of Enum, +-- so Number should be an instance too. Also, this is a prerequisite +-- of being an instance of Integral. + +instance Enum Number where + + succ = eitherOp1 succ succ + pred = eitherOp1 pred pred + + toEnum i = Exact (toEnum i) + fromEnum x = case x of + Exact i -> fromEnum i + Inexact r -> fromEnum r + + -- Use default definitions for these methods: + -- enumFrom :: a -> [a] -- [n..] + -- enumFromThen :: a -> a -> [a] -- [n,n'..] + -- enumFromTo :: a -> a -> [a] -- [n..m] + -- enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] + + +-- | Numbers are Integral, i.e., can do integer division and convert to +-- Integer. However, there is a restriction: this only works for Exact +-- numbers; for Inexact, there will be an error. +-- Some may see this as regrettable, but how is it different in principle +-- from division, which doesn't work for zero divisors, and +-- square root, which doesn't work for negative numbers? + +instance Integral Number where + + quot = exactOp2 "quot" quot + rem = exactOp2 "rem" rem + div = exactOp2 "div" div + mod = exactOp2 "mod" mod + + Exact i `quotRem` Exact j = + let (q, r) = i `quotRem` j in (Exact q, Exact r) + _ `quotRem` _ = error "Number:quotRem: inexact operand(s)" + + Exact i `divMod` Exact j = + let (d, m) = i `divMod` j in (Exact d, Exact m) + _ `divMod` _ = error "Number:divMod: inexact operand(s)" + + toInteger (Exact i) = i + toInteger _ = error "Number:toInteger: inexact operand" + + + +-- | Numbers are Fractional, i.e., support division and conversion +-- from Rational. +-- This works directly for inexact Numbers, and otherwise by +-- conversion from Exact to Inexact. +instance Fractional Number where + + (/) = inexactOp2 (/) + recip = inexactOp1 recip + fromRational r = Inexact (fromRational r) + +-- | Numbers are Floating, i.e., support exponential, log, and trig functions. +-- This works directly for inexact Numbers, and otherwise by +-- conversion from Exact to Inexact. +instance Floating Number where + + pi = Inexact pi + + exp = inexactOp1 exp + log = inexactOp1 log + + sqrt = inexactOp1 sqrt + + sin = inexactOp1 sin + cos = inexactOp1 cos + tan = inexactOp1 tan + + asin = inexactOp1 asin + acos = inexactOp1 acos + atan = inexactOp1 atan + + sinh = inexactOp1 sinh + cosh = inexactOp1 cosh + tanh = inexactOp1 tanh + asinh = inexactOp1 asinh + acosh = inexactOp1 acosh + atanh = inexactOp1 atanh + + -- These methods have defaults: + -- (**), logBase :: a -> a -> a + +instance RealFrac Number where + + properFraction x = + case x of + Exact i -> (fromIntegral i, Inexact 0.0) + Inexact r -> let (w, p) = properFraction r + in (w, Inexact p) + + -- Default methods: + -- truncate :: (Integral b) => a -> b + -- round :: (Integral b) => a -> b + -- ceiling :: (Integral b) => a -> b + -- floor :: (Integral b) => a -> b + + +-- Haskell functions that implement certain Sifflet functions. + +add1 :: Number -> Number +add1 = (+ 1) + +sub1 :: Number -> Number +sub1 = (+ (-1)) + +eqZero :: Number -> Bool +eqZero = (== 0) + +gtZero :: Number -> Bool +gtZero = (> 0) + +ltZero :: Number -> Bool +ltZero = (< 0) + +-- Omitting instance RealFloat, this is for data +-- that are *really* floating-point! diff --git a/Sifflet/Data/Number.hs b/Sifflet/Data/Number.hs deleted file mode 100644 --- a/Sifflet/Data/Number.hs +++ /dev/null @@ -1,288 +0,0 @@ --- | This module provides the Number type and many operations upon it. --- Most of the operations are provided by making Number an instance --- of the classes Num, Real, Enum, Integral, Fractional, Floating, --- and RealFrac. These are, I think, all of the normal Haskell --- numeric type classes *except* RealFloat. --- There are also a few functions defined in addition to the --- class methods. --- --- The *primary* purpose of this module is to be the library module --- used by Sifflet programs exported to Haskell. --- The *secondary* purpose (maybe no less important, but --- realized after the first) is to implement the Sifflet --- number Values (currently done with the VInt and VFloat constructors). - -module Sifflet.Data.Number - ( - Number(..) - , isExact, toInexact - , add1, sub1, eqZero, gtZero, ltZero - -- The following are only for testing, and should ultimately go to - -- the tests directory: - , testI, testJ, testX, testY - ) - -where - --- | A Number represents a real number, which can be exact (Integer) --- or inexact (Double). - -data Number = Exact Integer | Inexact Double - deriving (Eq, Read) - --- | Tell whether a Number is exact -isExact :: Number -> Bool -isExact (Exact _) = True -isExact _ = False - --- | Take a number, which may be exact or inexact, and --- produce the inexact number which equals it. --- Note that there is no inverse function toExact, --- because some inexact numbers like 3.5 are not equal to any exact number. --- The class RealFrac provides methods round, ceiling, floor, truncate --- for converting to exact numbers. - -toInexact :: Number -> Number -toInexact (Exact x) = Inexact (fromIntegral x) -toInexact xx = xx - -toDouble :: Number -> Double -toDouble (Exact ix) = fromIntegral ix -toDouble (Inexact rx) = rx - --- | Unary operations fall into two groups: --- exactOp1 works only for an exact operand; --- it is an error if the operand is inexact. --- The result is always exact. --- (Unused) --- inexactOp1 works directly for an inexact operand; --- otherwise by conversion of its exact operand to inexact; --- the result is always inexact. --- eitherOp1 works for either exact or inexact operand, --- and the result is exact if and only if the operand is exact. - -exactOp1 :: String -> (Integer -> Integer) -> (Number -> Number) -exactOp1 name f x = - case x of - Exact i -> Exact (f i) - _ -> error ("Number:" ++ name ++ ": inexact operand: " ++ show x) - -inexactOp1 :: (Double -> Double) -> (Number -> Number) --- inexactOp1 f x = Inexact (f (toDouble x)) -inexactOp1 f = Inexact . f . toDouble - -eitherOp1 :: (Integer -> Integer) -> (Double -> Double) - -> (Number -> Number) -eitherOp1 fi fr arg = - case arg of - Exact i -> Exact (fi i) - Inexact r -> Inexact (fr r) - --- | Binary operations fall in 3 groups: --- exactOp2 is implemented only for exact, exact operands; --- if there's any inexact operand, it's an error. --- Integer division operations (quot, rem, div, mod) --- are like this. The result is always exact. --- eitherOp2 is implemented directly for exact, exact operands --- and inexact, inexact operands; if one operand is --- exact and the other inexact, the exact operand --- is converted to inexact. Most arithmetic operations --- (+, -, *) are like this. The result may be exact or inexact. --- inexactop2 is directly implemented for inexact, inexact operands, --- but handles exact operands by converting them to inexact --- (even if both are exact). Math functions such as --- exp, log, sqrt, and sin are like this. The result --- is always inexact. - -exactOp2 :: String -> (Integer -> Integer -> Integer) - -> (Number -> Number -> Number) - -exactOp2 _ f (Exact i) (Exact j) = Exact (f i j) -exactOp2 name _ x y = - error ("Number:" ++ name ++ ": inexact operand(s): " ++ - show x ++ ", " ++ show y) - -inexactOp2 :: (Double -> Double -> Double) - -> (Number -> Number -> Number) - -inexactOp2 f x y = Inexact (f (toDouble x) (toDouble y)) - - -eitherOp2 :: (Integer -> Integer -> Integer) - -> (Double -> Double -> Double) - -> (Number -> Number -> Number) - -eitherOp2 fi _ (Exact i) (Exact j) = Exact (fi i j) -eitherOp2 _ fx x y = Inexact (fx (toDouble x) (toDouble y)) - - --- | This Show instance will not be compatible with the --- derived Read instance above -- so fix it. --- (And yet, mysteriously, ghci accepts 1 and 1.0 as Number literals.) - -instance Show Number where - show (Exact i) = show i - show (Inexact x) = show x - --- | Number as an ordered type -instance Ord Number where - compare (Exact x) (Exact y) = compare x y - compare (Inexact x) (Inexact y) = compare x y - compare (Exact x) (Inexact y) = compare (fromIntegral x) y - compare (Inexact x) (Exact y) = compare x (fromIntegral y) - -- This could take the place of the previous two: - -- compare mx my = compare (toInexact mx) (toInexact my) - --- | Number as an instance of Num -instance Num Number where - (+) = eitherOp2 (+) (+) - (-) = eitherOp2 (-) (-) - (*) = eitherOp2 (*) (*) - - negate = eitherOp1 negate negate - abs = eitherOp1 abs abs - signum = eitherOp1 signum signum - - fromInteger = Exact - --- | Numbers are Real, i.e., can be converted to Rational -instance Real Number where - toRational (Exact i) = toRational i - toRational (Inexact x) = toRational x - --- | In Haskell both Intgeger and Double are instances of Enum, --- so Number should be an instance too. Also, this is a prerequisite --- of being an instance of Integral. - -instance Enum Number where - - succ = eitherOp1 succ succ - pred = eitherOp1 pred pred - - toEnum i = Exact (toEnum i) - fromEnum x = case x of - Exact i -> fromEnum i - Inexact r -> fromEnum r - - -- Use default definitions for these methods: - -- enumFrom :: a -> [a] -- [n..] - -- enumFromThen :: a -> a -> [a] -- [n,n'..] - -- enumFromTo :: a -> a -> [a] -- [n..m] - -- enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] - - --- | Numbers are Integral, i.e., can do integer division and convert to --- Integer. However, there is a restriction: this only works for Exact --- numbers; for Inexact, there will be an error. --- Some may see this as regrettable, but how is it different in principle --- from division, which doesn't work for zero divisors, and --- square root, which doesn't work for negative numbers? - -instance Integral Number where - - quot = exactOp2 "quot" quot - rem = exactOp2 "rem" rem - div = exactOp2 "div" div - mod = exactOp2 "mod" mod - - Exact i `quotRem` Exact j = - let (q, r) = i `quotRem` j in (Exact q, Exact r) - _ `quotRem` _ = error "Number:quotRem: inexact operand(s)" - - Exact i `divMod` Exact j = - let (d, m) = i `divMod` j in (Exact d, Exact m) - _ `divMod` _ = error "Number:divMod: inexact operand(s)" - - toInteger (Exact i) = i - toInteger _ = error "Number:toInteger: inexact operand" - - - --- | Numbers are Fractional, i.e., support division and conversion --- from Rational. --- This works directly for inexact Numbers, and otherwise by --- conversion from Exact to Inexact. -instance Fractional Number where - - (/) = inexactOp2 (/) - recip = inexactOp1 recip - fromRational r = Inexact (fromRational r) - --- | Numbers are Floating, i.e., support exponential, log, and trig functions. --- This works directly for inexact Numbers, and otherwise by --- conversion from Exact to Inexact. -instance Floating Number where - - pi = Inexact pi - - exp = inexactOp1 exp - log = inexactOp1 log - - sqrt = inexactOp1 sqrt - - sin = inexactOp1 sin - cos = inexactOp1 cos - tan = inexactOp1 tan - - asin = inexactOp1 asin - acos = inexactOp1 acos - atan = inexactOp1 atan - - sinh = inexactOp1 sinh - cosh = inexactOp1 cosh - tanh = inexactOp1 tanh - asinh = inexactOp1 asinh - acosh = inexactOp1 acosh - atanh = inexactOp1 atanh - - -- These methods have defaults: - -- (**), logBase :: a -> a -> a - -instance RealFrac Number where - - properFraction x = - case x of - Exact i -> (fromIntegral i, Inexact 0.0) - Inexact r -> let (w, p) = properFraction r - in (w, Inexact p) - - -- Default methods: - -- truncate :: (Integral b) => a -> b - -- round :: (Integral b) => a -> b - -- ceiling :: (Integral b) => a -> b - -- floor :: (Integral b) => a -> b - - --- Haskell functions that implement certain Sifflet functions. - -add1 :: Number -> Number -add1 = (+ 1) - -sub1 :: Number -> Number -sub1 = (+ (-1)) - -eqZero :: Number -> Bool -eqZero = (== 0) - -gtZero :: Number -> Bool -gtZero = (> 0) - -ltZero :: Number -> Bool -ltZero = (< 0) - --- Omitting instance RealFloat, this is for data --- that are *really* floating-point! - --- ------------------------------------------------------------------------ --- TESTING --- ------------------------------------------------------------------------ - -testI, testJ, testK :: Number -testI = Exact 32 -testJ = Exact 35 -testK = 40 - -testX, testY, testZ :: Number -testX = Inexact 32.0 -testY = Inexact 35.0 -testZ = 37.5 diff --git a/Sifflet/Examples.hs b/Sifflet/Examples.hs --- a/Sifflet/Examples.hs +++ b/Sifflet/Examples.hs @@ -11,9 +11,6 @@ where import Sifflet.Language.Expr --- import Sifflet.UI (VPToolkit(..), functionToolsFromLists, --- baseFunctionsRows) -import Sifflet.Util -- TEST COMPOUND FUNCTIONS @@ -94,7 +91,9 @@ buggySumFromZero :: Function buggySumFromZero = - let Succ body = stringToExpr "n + buggySumFromZero (n - 1)" + let body = ePlus (eSym "n") + (eCall "buggySumFromZero" + [eMinus (eSym "n") (eInt 1)]) in Function (Just "buggySumFromZero") [VpTypeNum] VpTypeNum (Compound ["n"] body) @@ -237,26 +236,14 @@ listSum :: Function listSum = Function (Just "sum") [VpTypeList VpTypeNum] VpTypeNum - (Compound ["xs"] sumbody1) - -sumbody1, sumbody2 :: Expr -sumbody1 = let xs = eSymbol "xs" - zero = eInt 0 - in eIf (eCall "null" [xs]) - zero - (ePlus (eCall "head" [xs]) - (eCall "sum" [eCall "tail" [xs]])) - -sumbody2 = - let Succ body = - stringToExpr "if null xs then 0 else (head xs) + (sum' (tail xs))" - in body + (Compound ["xs"] sumbody) -listSum' :: Function -listSum' = - Function (Just "sum'") - [VpTypeList VpTypeNum] VpTypeNum - (Compound ["xs"] sumbody2) +sumbody :: Expr +sumbody = + eIf (eCall "null" [eSym "xs"]) + (eInt 0) + (ePlus (eCall "head" [eSym "xs"]) + (eCall "sum" [eCall "tail" [eSym "xs"]])) buggySum :: Function buggySum = let xs = eSymbol "xs" diff --git a/Sifflet/Foreign/Exporter.hs b/Sifflet/Foreign/Exporter.hs --- a/Sifflet/Foreign/Exporter.hs +++ b/Sifflet/Foreign/Exporter.hs @@ -1,8 +1,191 @@ -module Sifflet.Foreign.Exporter (Exporter) where +module Sifflet.Foreign.Exporter + (Exporter + , simplifyExpr + , commonRuleHigherPrec + , commonRuleAtomic + , commonRuleLeftToRight + , commonRuleAssocRight + , commonRuleFuncOp + , commonRulesForSimplifyingExprs + , ruleIfRight + , ruleRightToLeft + , applyFirstMatch + , findFixed + ) -import System.FilePath +where + import Sifflet.Language.Expr -- | The type of a function to export (user) functions to a file. type Exporter = Functions -> FilePath -> IO () + +-- | Simplify an expression by applying rules +-- top-down throughout the expression +-- tree and repeatedly until there is no change. +-- This is intended for removing extra parentheses, +-- but could be used for other forms of simplification. +-- +-- Should each rule also know the level in the original expr tree, +-- with 0 = top level (root)? +-- That would require additional arguments. + +simplifyExpr :: [Expr -> Expr] -> Expr -> Expr +simplifyExpr rules expr = + findFixed (topDown (applyFirstMatch rules)) expr + +-- | Repeatedly apply a function to an object until there is no change, +-- that is, until reaching a fixed point of the function, a point +-- where f x == x. + +findFixed :: (Eq a) => (a -> a) -> a -> a +findFixed f x = + let x' = f x + in if x' == x then x else findFixed f x' + + +-- | Common rules for simplifying parentheses. + +-- | Remove ()'s around a higher precedence operator: e.g., +-- (a * b) + c ==> a * b + c +-- a + (b * c) ==> a + b * c + +commonRuleHigherPrec :: Expr -> Expr +commonRuleHigherPrec e = + case e of + EOp op1 (EGroup (EOp op2 subleft subright)) right -> + -- left side + if opPrec op2 > opPrec op1 + then EOp op1 (EOp op2 subleft subright) right + else e + EOp op1 left (EGroup (EOp op2 subleft subright)) -> + -- right side + if opPrec op2 > opPrec op1 + then EOp op1 left (EOp op2 subleft subright) + else e + _ -> e + +-- | Remove ()'s around an atomic expression -- a variable, +-- literal, or list + +commonRuleAtomic :: Expr -> Expr +commonRuleAtomic e = + case e of + EGroup e' -> + if exprIsAtomic e' + then e' + else e + _ -> e + +-- | Remove ()'s in the case of (a op1 b) op2 c, +-- if op1 and op2 have the same precedence, and +-- both group left to right, since +-- left to right evaluation makes them unnecessary. + +commonRuleLeftToRight :: Expr -> Expr +commonRuleLeftToRight e = + case e of + EOp op2 (EGroup (EOp op1 a b)) c -> + if opPrec op1 == opPrec op2 && + opGrouping op1 == GroupLtoR && + opGrouping op2 == GroupLtoR + then EOp op2 (EOp op1 a b) c + else e + _ -> e + +-- | Remove ()'s in the case of a op (b op c) +-- if op groups right to left, and note that +-- it is the same operator op in both places +-- (though I don't know if that restriction is necessary). +-- This applies to (:) in Haskell, for example: +-- x : y : zs == x : (y : zs) + +ruleRightToLeft :: Expr -> Expr +ruleRightToLeft e = + case e of + EOp op1 a (EGroup (EOp op2 b c)) -> + if op1 == op2 && opGrouping op1 == GroupRtoL + then EOp op1 a (EOp op2 b c) + else e + _ -> e + +-- Associativity on the right +-- x + (y + z) --> x + y + z +-- for + and all other associative operators. +-- We could add, the left-hand rule +-- (x + y) + z --> x + y + z +-- but do not need it, +-- because it is already covered by the left to right rule +-- for operators of equal precedence. +-- It must be the SAME operator on both sides, of course! + +commonRuleAssocRight :: Expr -> Expr +commonRuleAssocRight e = + case e of + EOp op1 a (EGroup (EOp op2 b c)) -> + if op1 == op2 && opAssoc op1 + then EOp op1 a (EOp op2 b c) + else e + _ -> e + +-- An if expression as the right operand can be unparenthesized. +-- but not so on the left (at least in Haskell): +-- x + (if ...) --> x + if ... +-- but NOT +-- (if ...) + x --> if ... + x (NOT!) + +ruleIfRight :: Expr -> Expr +ruleIfRight e = + case e of + EOp op a (EGroup i@(EIf _ _ _)) -> EOp op a i + _ -> e + +-- In Haskell, a function application has precedence over all +-- operators. This applies in both the left and right operands. + +commonRuleFuncOp :: Expr -> Expr +commonRuleFuncOp e = + case e of + EOp op a (EGroup c@(ECall _ _)) -> EOp op a c + EOp op (EGroup c@(ECall _ _)) b -> EOp op c b + _ -> e + +-- | A list of common rules for simplifying expressions. +-- Does *not* include ruleIfRight, since that works +-- for Haskell but not Python. + +commonRulesForSimplifyingExprs :: [Expr -> Expr] +commonRulesForSimplifyingExprs = + [commonRuleHigherPrec + , commonRuleAtomic + , commonRuleLeftToRight + , commonRuleAssocRight + , commonRuleFuncOp] + +-- | Try the first rule in a list to see if it changes an expression, +-- returning the new expression if it does; otherwise, try the next rule, +-- and so on; if no rule changes the expression, then return the expression. +-- (Note that (applyFirstMatch rules) is itself a rule.) + +applyFirstMatch :: [Expr -> Expr] -> Expr -> Expr +applyFirstMatch [] e = e +applyFirstMatch (r:rs) e = + let e' = r e + in if e' /= e + then e' + else applyFirstMatch rs e + +-- | Apply a rule top-down to all levels of an expression. +-- Normally, the "rule" would be a value of (applyFirstMatch rules). +topDown :: (Expr -> Expr) -> Expr -> Expr +topDown f e = + let tdf = topDown f + e' = f e + in case e' of + EIf c a b -> EIf (tdf c) (tdf a) (tdf b) + EList xs -> EList (map tdf xs) + ECall fsym args -> ECall fsym (map tdf args) + EOp op left right -> EOp op (tdf left) (tdf right) + EGroup e'' -> EGroup (tdf e'') + _ -> e' diff --git a/Sifflet/Foreign/Haskell.hs b/Sifflet/Foreign/Haskell.hs new file mode 100644 --- /dev/null +++ b/Sifflet/Foreign/Haskell.hs @@ -0,0 +1,155 @@ +-- | Abstract syntax tree and pretty-printing for Haskell 98. +-- This is only a small subset of the Haskell 98 syntax, +-- so we do not need to pull in haskell-src and all its complexity. +-- Moreover, haskell-src gives too little control over the format +-- of pretty-printed text output. + +module Sifflet.Foreign.Haskell + (HsPretty(..) + , Module(..) + , ExportSpec(..) + , ImportDecl(..) + , Decl(..) + , operatorTable + ) + +where + +import Data.List (intercalate) +import qualified Data.Map as M + +import Sifflet.Language.Expr +import Sifflet.Text.Pretty + +class HsPretty a where + + hsPretty :: a -> String + + hsPrettyList :: String -> String -> String -> [a] -> String + hsPrettyList pre tween post xs = + pre ++ intercalate tween (map hsPretty xs) ++ post + +instance HsPretty Symbol where + hsPretty = pretty + +instance HsPretty Operator where + hsPretty = pretty + +-- | A Haskell module; moduleDecls are functions and variables. + +data Module = Module {moduleName :: String + , moduleExports :: Maybe ExportSpec + , moduleImports :: ImportDecl + , moduleDecls :: [Decl] + } + deriving (Eq, Show) + +instance HsPretty Module where + hsPretty m = + let pmod = "module " ++ moduleName m + pexports = case moduleExports m of + Nothing -> "" + Just exports -> hsPretty exports + pimports = hsPretty (moduleImports m) + pdecls = sepLines2 (map hsPretty (moduleDecls m)) + in unlines [pmod ++ " where", + pexports, + pimports, + pdecls] + +-- | A Haskell module's export spec: a list of function and +-- variable identifiers +data ExportSpec = ExportSpec [String] + deriving (Eq, Show) + +instance HsPretty ExportSpec where + hsPretty (ExportSpec exports) = + "(" ++ sepCommaSp exports ++ ")" + +-- | A Haskell modules import decls: a list of module identifiers. +-- No support for "qualified" or "as" or for selecting only some +-- identifiers from the imported modules. + +data ImportDecl = ImportDecl [String] + deriving (Eq, Show) + +instance HsPretty ImportDecl where + hsPretty (ImportDecl modnames) = + let idecl modname = "import " ++ modname + in unlines (map idecl modnames) + +-- | Wrap a string in parentheses +par :: String -> String +par s = "(" ++ s ++ ")" + +-- | A Haskell function or variable declaration. +-- An explicit type declaration is optional. +-- Thus we have just enough for +-- name :: type +-- name [args] = expr. +-- Of course [args] would be empty if it's just a variable. +data Decl = Decl {declIdent :: String + , declType :: Maybe [String] + , declParams :: [String] + , declExpr :: Expr + } + deriving (Eq, Show) + +instance HsPretty Decl where + hsPretty decl = + let ptypeDecl = "" -- to be improved ** + pparams = case declParams decl of + [] -> "" + params -> " " ++ sepSpace params + pbody = hsPretty (declExpr decl) + in ptypeDecl ++ + declIdent decl ++ pparams ++ " =\n" ++ + " " ++ pbody + +-- | HsPretty expressions. This is going to be like in Python.hs. +instance HsPretty Expr where + hsPretty pexpr = + case pexpr of + EUndefined -> "undefined" + EChar c -> show c + ENumber n -> show n + EBool b -> show b + EString s -> show s + ESymbol sym -> hsPretty sym + EList xs -> hsPrettyList "[" ", " "]" xs + EIf c a b -> + unwords ["if", hsPretty c, "then", hsPretty a, "else", hsPretty b] + EGroup e -> par (hsPretty e) + ECall fexpr argExprs -> + hsPretty fexpr ++ " " ++ hsPrettyList "" " " "" argExprs + EOp op left right -> + unwords [hsPretty left, hsPretty op, hsPretty right] + +-- | The Haskell operators. +-- Now what about the associativity of (:)? +-- It really doesn't even make sense to ask if (:) is +-- associative in the usual sense, +-- since (x1 : x2) : xs == x1 : (x2 : xs) +-- is not only untrue, but the left-hand side is +-- a type error, except maybe in some very special cases +-- (and then the right-hand side would probably be a type error). +-- Is (:) what is called a "right-associative" operator? +-- And do I need to expand my Operator type to +-- include this? And then what about (-) and (/)??? +-- Does this affect their relationship with (+) and (-)? + +operatorTable :: M.Map String Operator +operatorTable = + M.fromList (map (\ op -> (opName op, op)) + [ Operator "*" 7 True GroupLtoR -- times + , Operator "+" 6 True GroupLtoR -- plus + , Operator "-" 6 False GroupLtoR -- minus + , Operator ":" 5 False GroupRtoL -- cons + , Operator "==" 4 False GroupNone -- eq + , Operator "/=" 4 False GroupNone -- ne + , Operator ">" 4 False GroupNone -- gt + , Operator ">=" 4 False GroupNone -- ge + , Operator "<" 4 False GroupNone -- lt + , Operator "<=" 4 False GroupNone -- le + ]) + diff --git a/Sifflet/Foreign/Python.hs b/Sifflet/Foreign/Python.hs --- a/Sifflet/Foreign/Python.hs +++ b/Sifflet/Foreign/Python.hs @@ -6,174 +6,111 @@ -- over pretty-printing of Python expressionsw. module Sifflet.Foreign.Python - (PModule(..) + (PyPretty(..) + , PModule(..) , PStatement(..) - , PExpr(..) - , PIdentifier(..) - , PParameter(..) - , POperator(..) - , Precedence , alterParens - , atomic - , compound , ret , condS - , condE , var , ident - , pInt - , pFloat - , bool , char - , string - , paren - , noParens - , fullParens - , bestParens - , simplifyParens - , par - , unpar - , call - , param , fun - , opTimes - , opIDiv - , opFDiv - , opMod - , opPlus - , opMinus - , opEq - , opNe - , opGt - , opGe - , opLt - , opLe + , operatorTable ) where +import Data.List (intercalate) +import qualified Data.Map as M + +import Sifflet.Language.Expr import Sifflet.Text.Pretty --- | The class of types that can be parenthesized, that is, --- they may contain parentheses, and their parentheses may be altered. --- class Parenthesize a where --- alterParens :: (PExpr -> PExpr) -> a -> a --- ^^ Don't need a class for this! +class PyPretty a where --- This doesn't seem right. It is too general. --- instance (Pretty a) => Pretty [a] where --- pretty as = sepCommaSp (map pretty as) + pyPretty :: a -> String -prettyParens :: (Pretty a) => [a] -> String -prettyParens = prettyList "(" ", " ")" + pyPrettyList :: String -> String -> String -> [a] -> String + pyPrettyList pre tween post xs = + pre ++ intercalate tween (map pyPretty xs) ++ post -prettyBrackets :: (Pretty a) => [a] -> String -prettyBrackets = prettyList "[" ", " "]" +pyPrettyParens :: (PyPretty a) => [a] -> String +pyPrettyParens = pyPrettyList "(" ", " ")" +instance PyPretty Symbol where + pyPretty = pretty + +instance PyPretty Operator where + pyPretty = pretty + -- | Python module -- essentially a list of statements; -- should it also have a name? data PModule = PModule [PStatement] deriving (Eq, Show) -instance Pretty PModule where - pretty (PModule ss) = sepLines2 (map pretty ss) +instance PyPretty PModule where + pyPretty (PModule ss) = sepLines2 (map pyPretty ss) -- | Python statement -data PStatement = PReturn PExpr +data PStatement = PReturn Expr | PImport String -- ^ import statement - | PCondS PExpr + | PCondS Expr PStatement PStatement -- ^ if condition action alt-action - | PFun PIdentifier - [PParameter] + | PFun Symbol + [Symbol] PStatement -- ^ function name, formal parameters, body deriving (Eq, Show) -instance Pretty PStatement where - pretty s = +instance PyPretty PStatement where + pyPretty s = case s of - PReturn e -> "return " ++ pretty e + PReturn e -> "return " ++ pyPretty e PImport modName -> "import " ++ modName PCondS c a b -> - sepLines ["if " ++ pretty c ++ ":", - indentLine 4 (pretty a), + sepLines ["if " ++ pyPretty c ++ ":", + indentLine 4 (pyPretty a), "else:", - indentLine 4 (pretty b)] + indentLine 4 (pyPretty b)] PFun fid params body -> - sepLines ["def " ++ pretty fid ++ - prettyParens params ++ ":", - indentLine 4 (pretty body)] - - --- | Python expression -data PExpr = PCondE PExpr - PExpr - PExpr -- ^ if: condition, value, alt-value - | PParen PExpr -- ^ expression in parentheses; is this needed? - | PCall PExpr - [PExpr] -- ^ function call: function expression (typically a PVariable), argument expressions - | POperate POperator - PExpr - PExpr -- ^ binary operation: operator, left, right - -- base cases - | PVariable PIdentifier -- ^ variable identifier - | PInt Integer - | PFloat Double - | PBool Bool - | PString String - deriving (Eq, Show) + sepLines ["def " ++ pyPretty fid ++ + pyPrettyParens params ++ ":", + indentLine 4 (pyPretty body)] --- | PExpr as an instance of Pretty. --- The POperate case needs work to deal with precedences --- and avoid unnecessary parens -instance Pretty PExpr where - pretty pexpr = +-- | Expr as an instance of PyPretty. +-- This instance is only for Exprs as Python exprs, +-- for export to Python! It will conflict with the +-- one in ToHaskell.hs (or Haskell.hs). +-- +-- The EOp case needs work to deal with precedences +-- and avoid unnecessary parens. +-- Note that this instance declaration is for *Python* Exprs. +-- Haskell Exprs of course should not be pretty-printed +-- the same way! +instance PyPretty Expr where + pyPretty pexpr = case pexpr of - PCondE c a b -> - unwords [pretty a, "if", pretty c, "else", pretty b] - PParen e -> prettyParens [e] - PVariable vid -> pretty vid - PInt i -> show i - PFloat x -> show x - PBool b -> show b - PString s -> show s - PCall fexpr argExprs -> - concat [pretty fexpr, prettyParens argExprs] - POperate op left right -> - unwords [pretty left, pretty op, pretty right] - - --- | Python identifier (variable name, etc.) -data PIdentifier = PIdentifier String - deriving (Eq, Show) - -instance Pretty PIdentifier where - pretty (PIdentifier s) = s - --- | Python function formal parameter -data PParameter = PParameter PIdentifier - deriving (Eq, Show) - -instance Pretty PParameter where - pretty (PParameter pident) = pretty pident - --- | Python operator, such as * or + -data POperator = POperator {opName :: String, - opPrec :: Precedence, - opAssoc :: Bool -- ^ associative? - } - deriving (Eq, Show) - -instance Pretty POperator where - pretty (POperator s _ _) = s - --- | Operator priority, actually should be > 0 or >= 0 -type Precedence = Int - --- | Alter the parentheses of a statement by applying a --- transformer t to the expressions in the statement. + EUndefined -> "undefined" + EChar _ -> error ("Python pyPretty of Expr: " ++ + "EChar should have been converted to " ++ + "EString") + EList _ -> error ("Python pyPretty of Expr: " ++ + "EList should have been converted to " ++ + "ECall li ...") + EIf c a b -> + unwords [pyPretty a, "if", pyPretty c, "else", pyPretty b] + EGroup e -> pyPrettyParens [e] + ESymbol vid -> pyPretty vid + ENumber n -> show n + EBool b -> show b + EString s -> show s + ECall fexpr argExprs -> + concat [pyPretty fexpr, pyPrettyParens argExprs] + EOp op left right -> + unwords [pyPretty left, pyPretty op, pyPretty right] -alterParens :: (PExpr -> PExpr) -> PStatement -> PStatement +alterParens :: (Expr -> Expr) -> PStatement -> PStatement alterParens t s = case s of PReturn e -> PReturn (t e) @@ -181,22 +118,9 @@ PFun fid params b -> PFun fid params (alterParens t b) _ -> s -atomic :: PExpr -> Bool -atomic pexpr = - case pexpr of - PVariable _ -> True - PInt _ -> True - PFloat _ -> True - PBool _ -> True - PString _ -> True - _ -> False -compound :: PExpr -> Bool -compound = not . atomic - - -- | Python return statement -ret :: PExpr -> PStatement +ret :: Expr -> PStatement ret pexpr = PReturn pexpr -- | Python if STATEMENT @@ -209,197 +133,29 @@ -- -- But do I need this at all? -condS :: PExpr -> PExpr -> PExpr -> PStatement +condS :: Expr -> Expr -> Expr -> PStatement condS c a b = PCondS c (ret a) (ret b) --- | Python if EXPRESSION - --- This is the if EXPRESSION: --- "a if c else b", which means (in Haskell) "if c then a else b". --- I didn't even know there was such a thing! --- It works in both Python 2.6.5 and 3.1.2. -condE :: PExpr -> PExpr -> PExpr -> PExpr -condE c a b = PCondE c a b -- paren (PCondE c a b) - -- PExpr smart constructors -- | Python variable -var :: String -> PExpr -var name = PVariable (PIdentifier name) +var :: String -> Expr +var name = ESymbol (Symbol name) -- | Python identifier -ident :: String -> PIdentifier -ident s = PIdentifier s - --- | Python integer expression -pInt :: Integer -> PExpr -pInt i = PInt i - --- | Python float expression -pFloat :: Double -> PExpr -pFloat x = PFloat x - --- | Python boolean expression -bool :: Bool -> PExpr -bool b = PBool b +ident :: String -> Symbol +ident s = Symbol s -- | Python character expression = string expression with one character -char :: Char -> PExpr -char c = string [c] - --- | Python string expression -string :: String -> PExpr -string s = PString s - --- | Python expression in parentheses. - --- Wraps parentheses around an expression. --- This is needed (at least sometimes!) --- in calls and binary operator applications. --- Also in condE! --- I'm doing it always to be safe (but ugly, not pretty!!) - -paren :: PExpr -> PExpr -paren pexpr = PParen pexpr - --- | Remove all grouping parentheses in expression. --- Does not affect parentheses required for function arguments --- or parameters. --- This will sometimes alter the semantics. - --- I don't need noParens; it's just here as an exercise -noParens :: PExpr -> PExpr -noParens pexpr = - let t = noParens - in case pexpr of - PParen e -> t e - PCondE c a b -> PCondE (t c) (t a) (t b) - PCall fe aes -> PCall (t fe) (map t aes) - POperate op left right -> POperate op (t left) (t right) - -- remaining cases are simple and therefore have no parens - _ -> pexpr - --- | Wrap each subexpression in grouping parentheses. --- This will typically look like too many parentheses. - --- I don't need fullParens; it's just here as an exercise -fullParens :: PExpr -> PExpr -fullParens pexpr = - let t = paren . fullParens - in case pexpr of - PCondE c a b -> PCondE (t c) (t a) (t b) - PCall fe aes -> PCall (t fe) (map t aes) - POperate op left right -> POperate op (t left) (t right) - -- PParen and base cases need no more ()'s - _ -> pexpr - --- | Use parentheses for grouping where needed, --- but cautiously, erring on the side of extra parentheses if not sure --- they can be removed. - -bestParens :: PExpr -> PExpr -bestParens = simplifyParens . fullParens - --- | Remove grouping parentheses that are provably not needed. --- This may not remove *all* unnecessary grouping parentheses. --- You can always add more cases to make it better! - -simplifyParens :: PExpr -> PExpr -simplifyParens pexpr = - let t = simplifyParens - ut = unpar . t - in case pexpr of - PParen e -> - -- 1. Atomic expressions, like 5, do not need parens, - -- because there is nothing to be grouped - if atomic e - then e - else case e of - -- function call (fact(n)) -> fact(n) - PCall _ _ -> ut e - _ -> PParen (t e) - PCondE c a b -> PCondE (ut c) (ut a) (ut b) - PCall fe aes -> PCall (t fe) (map ut aes) - POperate op left right -> - sop (POperate op (t left) (t right)) - -- remaining cases are simple and therefore have no parens - _ -> pexpr - --- | Various rules for removing extra parentheses in operations. --- Probably incomplete. If the PExpr is not an operation, then --- it is passed through without change. -sop :: PExpr -> PExpr -sop = sopLeft . sopRight - -sopLeft :: PExpr -> PExpr -sopLeft pexpr = - case pexpr of - POperate op1 (PParen (POperate op2 left2 right2)) right -> - if opPrec op2 > opPrec op1 - -- higher precedcence in left subtree - -- e.g. (a * b) + c ==> a * b + c - then POperate op1 (POperate op2 left2 right2) right - else if opPrec op2 == opPrec op1 - -- equal precedence operations, left to right - -- e.g. (a + b) - c ==> a + b - c - then POperate op1 (POperate op2 left2 right2) right - else pexpr - _ -> pexpr - -sopRight :: PExpr -> PExpr -sopRight pexpr = - case pexpr of - POperate op1 left (PParen (POperate op2 left2 right2)) -> - if opPrec op2 > opPrec op1 - -- higher precedcence in left subtree - -- e.g. (a * b) + c ==> a * b + c - then POperate op1 left (POperate op2 left2 right2) - else if op1 == op2 && opAssoc op1 - -- associative operation, e.g. - -- a + (b + c) ==> a + b + c - then POperate op1 left (POperate op2 left2 right2) - else pexpr - _ -> pexpr - - --- | Adding and removing top-level parentheses. --- Axioms: par (unpar e) == e; unpar (par e) == e. - --- | Add parentheses around an expression. Top level only. -par :: PExpr -> PExpr -par e = PParen e - --- | Remove parentheses around an expression. Top level only. -unpar :: PExpr -> PExpr -unpar pexpr = - case pexpr of - PParen e -> e - _ -> pexpr -- no-op - --- | The "operator precedence" of an expression. --- If the expression is an operation, then this is the --- precedence of its operator; --- otherwise, it's not clear what it should be, but for now, -1. - -exprPrec :: PExpr -> Precedence -exprPrec pexpr = - case pexpr of - POperate op _ _ -> opPrec op - _ -> (-1) - --- | Python function call expression -call :: String -> [PExpr] -> PExpr -call fname argExprs = PCall (var fname) argExprs - --- arg :: PExpr -> PArgument --- arg expr = ArgExpr {arg_expr = expr, arg_annot = ()} +char :: Char -> Expr +char c = EString [c] -- | Python function formal parameter -param :: String -> PParameter -param name = PParameter (ident name) +param :: String -> Symbol +param name = Symbol name -- | Defines function definition -fun :: String -> [String] -> PExpr -> PStatement +fun :: String -> [String] -> Expr -> PStatement fun fname paramNames bodyExpr = PFun (ident fname) (map param paramNames) (ret bodyExpr) @@ -410,26 +166,29 @@ -- I am adopting the infixr levels from Haskell, -- which seem to be consistent with Python, -- at least for the operators that Sifflet uses. - --- | Arithmetic operators +-- +-- | Operator information +-- Arithmetic operators: -- + and - have lower precedence than *, /, //, % -opTimes, opIDiv, opFDiv, opMod, opPlus, opMinus :: POperator -opTimes = POperator "*" 7 True -opIDiv = POperator "//" 7 False -opFDiv = POperator "/" 7 False -opMod = POperator "%" 7 False -opPlus = POperator "+" 6 True -opMinus = POperator "-" 6 False - -- | Comparison operators have precedence lower than any arithmetic -- operator. Here, I've specified associative = False, --- because association doesn't even make sense; +-- because association doesn't even make sense (well, it does in Python +-- but not in other languages); -- (a == b) == c is in general not well typed. -opEq, opNe, opGt, opGe, opLt, opLe :: POperator -opEq = POperator "==" 4 False -opNe = POperator "!=" 4 False -opGt = POperator ">" 4 False -opGe = POperator ">=" 4 False -opLt = POperator "<" 4 False -opLe = POperator "<=" 4 False +operatorTable :: M.Map String Operator +operatorTable = + M.fromList (map (\ op -> (opName op, op)) + [ (Operator "*" 7 True GroupLtoR) -- times + , (Operator "//" 7 False GroupLtoR) -- int div + , (Operator "/" 7 False GroupLtoR) -- float div + , (Operator "%" 7 False GroupLtoR) -- mod + , (Operator "+" 6 True GroupLtoR) -- plus + , (Operator "-" 6 False GroupLtoR) -- minus + , (Operator "==" 4 False GroupNone) -- eq + , (Operator "!=" 4 False GroupNone) -- ne + , (Operator ">" 4 False GroupNone) -- gt + , (Operator ">=" 4 False GroupNone) -- ge + , (Operator "<" 4 False GroupNone) -- lt + , (Operator "<=" 4 False GroupNone) -- le + ]) diff --git a/Sifflet/Foreign/ToHaskell.hs b/Sifflet/Foreign/ToHaskell.hs --- a/Sifflet/Foreign/ToHaskell.hs +++ b/Sifflet/Foreign/ToHaskell.hs @@ -4,50 +4,50 @@ module Sifflet.Foreign.ToHaskell ( HaskellOptions(..) - , HasParens(..) , defaultHaskellOptions , exportHaskell , functionsToHsModule , functionToHsDecl - , exprToHsExp - , valueToHsExp - , prettyModule + , exprToHsExpr ) where import Char (toUpper) -import Language.Haskell.Parser -- only for reverse engineering -import Language.Haskell.Syntax -import qualified Language.Haskell.Pretty as HsPretty +import qualified Data.Map as M +import System.FilePath (dropExtension, takeFileName) import Sifflet.Foreign.Exporter +import Sifflet.Foreign.Haskell import Sifflet.Language.Expr -import Sifflet.Examples +import Sifflet.Util -import System.FilePath (dropExtension, takeFileName) -- Main types and functions -- | User configurable options for export to Haskell. --- Currently just a place-holder. -data HaskellOptions = HaskellOptions +-- Currently these options are unused. +-- The line width options should probably go somewhere else, +-- maybe as PrettyOptions. +data HaskellOptions = + HaskellOptions {optionsSoftMaxLineWidth :: Int + , optionsHardMaxLineWidth :: Int + } deriving (Eq, Show) -- | The default options for export to Haskell. defaultHaskellOptions :: HaskellOptions -defaultHaskellOptions = HaskellOptions +defaultHaskellOptions = HaskellOptions {optionsSoftMaxLineWidth = 72, + optionsHardMaxLineWidth = 80} -- | Export functions with specified options to a file --- Work needed: add a declaration "import Sifflet.Data.Number". exportHaskell :: HaskellOptions -> Exporter exportHaskell _options functions path = let header = "-- File: " ++ path ++ "\n-- Generated by the Sifflet->Haskell exporter.\n\n" in writeFile path (header ++ - hspp (simplifyParens - (functionsToHsModule - (pathToModuleName path) - functions))) + hsPretty (functionsToHsModule + (pathToModuleName path) + functions)) pathToModuleName :: FilePath -> String @@ -58,294 +58,78 @@ -- ------------------------------------------------------------------------ --- | Shortcuts for Hs*** data constructors, --- with lots of defaults for features I'm not using. - --- | There is no source location in the conventional sense. -srcLoc :: SrcLoc -srcLoc = SrcLoc {srcFilename = "", srcLine = 0, srcColumn = 0} - -- {srcFileName = " [HsImportDecl] -> [HsDecl] -> HsModule -hsModule name importDecls decls = - HsModule srcLoc (Module name) - Nothing -- :: Maybe [HsExportSpec] - importDecls - decls - --- | A Haskell import declaration -hsImportDecl :: String -> HsImportDecl -hsImportDecl name = - HsImportDecl {importLoc = srcLoc, - importModule = Module name, - importQualified = False, - importAs = Nothing, - importSpecs = Nothing} - - --- | A function binding (declaration and definition) -hsFunBind :: [HsMatch] -> HsDecl -hsFunBind matches = - HsFunBind matches - --- | Identifier, as the name of a function -hsIdent :: String -> HsName -hsIdent = HsIdent - --- | Symbol, as the name of an operator -hsSymbol :: String -> HsName -hsSymbol = HsSymbol - --- | Pattern variable, as in the argument list of a function --- (pattern match) - -hsPVar :: String -> HsPat -hsPVar = HsPVar . hsIdent - --- | A variable used in an expression (rather than in an argument list) -hsVar :: String -> HsExp -hsVar = HsVar . UnQual . hsIdent - --- | An infix operator application. --- Probably needs parentheses added. -hsOperate :: HsExp -> HsQOp -> HsExp -> HsExp -hsOperate left qop right = - HsInfixApp left qop right - --- | A prefix function application. --- Need to work some parentheses in here, probably. -hsCall :: HsExp -> [HsExp] -> HsExp -hsCall hfunc hargs = - case hargs of - [] -> - case hfunc of - HsVar (UnQual (HsIdent name)) -> hfunc - _ -> error ("hsCall: unexpected form of unary function: " ++ - show hfunc) - a : [] -> HsApp hfunc a - a : as -> hsCall (HsApp hfunc a) as - --- | An infix operator -hsOp :: String -> HsQOp --- hsOp name = HsQVarOp (UnQual (HsSymbol name)) -hsOp = HsQVarOp . UnQual . hsSymbol - --- | A clause of a function binding --- hsMatch :: ?? - --- ------------------------------------------------------------------------ - -- | Converting Sifflet to Haskell syntax tree -- | Create a module from a module name and Functions. -functionsToHsModule :: String -> Functions -> HsModule -functionsToHsModule mname (Functions fs) = - hsModule mname - [hsImportDecl "Sifflet.Data.Number"] -- sifflet-Haskell library - (map functionToHsDecl fs) - +functionsToHsModule :: String -> Functions -> Module +functionsToHsModule modname (Functions fs) = + Module {moduleName = modname + , moduleExports = Nothing + , moduleImports = ImportDecl ["Data.Number.Sifflet"] + , moduleDecls = map functionToHsDecl fs + } + -- | Create a declaration from a Function. -- Needs work: infer and declare the type of the function. -functionToHsDecl :: Function -> HsDecl -functionToHsDecl (Function mname atypes rtype impl) = +-- Minimally parenthesized. +functionToHsDecl :: Function -> Decl +functionToHsDecl (Function mname _atypes _rtype impl) = case (mname, impl) of (Nothing, _) -> error "functionToHsDecl: function has no name" (_, Primitive _) -> error "functionToHsDecl: function is primitive" (Just fname, Compound args body) -> - -- forget about type declarations for now - -- ... - HsFunBind [HsMatch srcLoc - (hsIdent fname) - (map hsPVar args) - (HsUnGuardedRhs (exprToHsExp body)) - [] -- decls (??) - ] - -exprToHsExp :: Expr -> HsExp -exprToHsExp expr = + Decl {declIdent = fname + , declType = Nothing -- to be improved later + , declParams = args + , declExpr = (simplifyExpr haskellRules) + (exprToHsExpr body)} + +haskellRules :: [Expr -> Expr] +haskellRules = commonRulesForSimplifyingExprs ++ + [ruleIfRight, ruleRightToLeft] + +-- | Converts a Sifflet Expr to a fully parenthesized Haskell Expr +exprToHsExpr :: Expr -> Expr +exprToHsExpr expr = case expr of - EUndefined -> hsVar "undefined" - ESymbol (Symbol s) -> hsVar s - ELit v -> valueToHsExp v - EIf c a b -> - HsIf (exprToHsExp c) (exprToHsExp a) (exprToHsExp b) - EList es -> HsList (map exprToHsExp es) + EUndefined -> ESymbol (Symbol "undefined") + ESymbol _ -> expr + EBool _ -> expr + EChar _ -> expr + ENumber _ -> expr + EString _ -> expr + + EIf c a b -> EIf (exprToHsExpr c) (exprToHsExpr a) (exprToHsExpr b) + EList es -> EList (map exprToHsExpr es) ECall (Symbol fname) args -> case nameToHaskell fname of - HsSymbol opName -> + Left op -> -- operator case args of [left, right] -> - HsParen (hsOperate (exprToHsExp left) - (hsOp opName) - (exprToHsExp right)) - _ -> error "exprToHsExp: operation does not have 2 operands" - HsIdent funcName -> - HsParen (hsCall (hsVar funcName) (map exprToHsExp args)) - --- ... and somewhere we need to work in HsParen hsExp as needed :-( - -valueToHsExp :: Value -> HsExp -valueToHsExp value = - case value of - VBool b -> HsCon (UnQual (HsIdent (if b then "True" else "False"))) - VChar c -> HsLit (HsChar c) - -- Should negative numbers get wrapped in parentheses?? - VInt i -> HsLit (HsInt i) - VFloat x -> HsLit (HsFrac (toRational x)) - VStr s -> HsLit (HsString s) - VFun _ -> error "valueToHsLiteral: I don't know how to convert a VFun" - VList vs -> HsList (map valueToHsExp vs) + EOp op (EGroup (exprToHsExpr left)) + (EGroup (exprToHsExpr right)) + _ -> error + "exprToHsExpr: operation does not have 2 operands" + Right funcName -> -- function + ECall (Symbol funcName) (map (EGroup . exprToHsExpr) args) + _ -> errcats ["exprToHsExpr: extended expr:", show expr] -- | Map Sifflet names to Haskell names. --- Returns the variant HsSymbol for operator names, HsIdent for others --- (function names, variables, etc.). --- This might need to be extended with fixity and associativity information, --- but that can come later when I start to deal with parentheses. -nameToHaskell :: String -> HsName +-- Returns a Left Operator for Haskell operators, +-- which always have the same name as their corresponding Sifflet +-- functions, or a Right String for Haskell function and variable names. +nameToHaskell :: String -> Either Operator String nameToHaskell name = - if elem name ["+", "-", "*", "/", - "==", "/=", "<", ">", "<=", ">=", - ":"] - then HsSymbol name - else - -- some special cases will need to be inserted here, - -- for zero?, positive? negative?, at least; - -- add1, sub1 too. - HsIdent (case name of - "zero?" -> "eqZero" - "positive?" -> "gtZero" - "negative?" -> "ltZero" - _ -> name) - --- ------------------------------------------------------------------------ --- | Simplifying parentheses --- This belongs elsewhere, since non-Haskelly things can also --- be instances. - -class HasParens a where - simplifyParens :: a -> a - -instance HasParens HsModule where - simplifyParens (HsModule locus name exportDecls importDecls decls) = - HsModule locus name exportDecls importDecls (map simplifyParens decls) - -instance HasParens HsDecl where - simplifyParens decl = - case decl of - HsFunBind [HsMatch locus fname args - (HsUnGuardedRhs body) - []] -> - HsFunBind [HsMatch locus fname args - (HsUnGuardedRhs (simplifyParens body)) - []] - _ -> - decl - -instance HasParens HsExp where - simplifyParens hexp = - let t = simplifyParens - ut = unpar . t - unpar e = - case e of - HsParen e' -> e' - _ -> e - in case hexp of - HsIf c a b -> HsIf (ut c) (ut a) (ut b) - HsList es -> HsList (map t es) - - HsParen e -> - if atomic e then e - else case e of - -- work needed here ... - _ -> hexp - -- Infix operator application - HsInfixApp left qop right -> - -- This *** needs work *** along the lines of Python.hs - HsInfixApp left qop right - -- Function applications: - -- (f a) b ---> f a b. - -- So why put the parentheses around f a in the first place? - HsApp (HsParen (HsApp hf ha)) hb -> - HsApp (HsApp hf ha) hb - _ -> hexp - --- | Is an expression atomic? Yes if it's a value, a boolean value --- (i.e., the unary constructor True or False), or a literal; otherwise no. --- Actually *any* unary constructor could be considered atomic, --- but I'm not sure how to deal with this. Not urgent, --- since Sifflet export uses no unary constructors but True and False. - -atomic :: HsExp -> Bool -atomic hexp = - case hexp of - HsVar (UnQual (HsIdent _)) -> True -- variable - HsCon (UnQual (HsIdent _)) -> True -- unary constructors: True, False - HsLit _ -> True -- literals - HsList _ -> False -- list - HsIf _ _ _ -> False -- if expression - HsInfixApp _ _ _ -> False - HsApp _ _ -> False - -- well what are the other cases? - _ -> error ("atomic: don't know how to handle: " ++ show hexp) - --- ------------------------------------------------------------------------ - --- | Facilities for testing - -asModule :: [String] -> String -asModule strings = unlines ("module Test where" : strings) - -test1 :: String -test1 = asModule [ - -- "foo :: Int -> Int -> Int", - "foo x y = x + y"] - -test2 :: String -test2 = asModule [ - "foo1 x = bar (codd x)", - "foo2 = bar . codd"] - -prettyDS :: [String] -> IO () -prettyDS declStrings = prettyModule (asModule declStrings) - -prettyES :: String -> IO () -prettyES expString = prettyModule (asModule ["x = " ++ expString]) - -hspp :: (HsPretty.Pretty a) => a -> String -hspp = HsPretty.prettyPrint - -prettyModule :: String -> IO () -prettyModule string = - case parseModule string of - ParseOk m -> putStrLn (hspp m) - ParseFailed loc msg -> putStrLn (show loc ++ ": " ++ msg) - -prettyE :: Expr -> IO () -prettyE expr = - putStrLn (hspp (exprToHsExp expr)) - -prettyV :: Value -> IO () -prettyV value = - putStrLn (hspp (valueToHsExp value)) - -testParse :: String -> ParseResult HsModule -testParse string = parseModule string - -testCallPrefix :: IO () -testCallPrefix = prettyE $ ECall (Symbol "mod") [ELit (VInt 7), ELit (VInt 5)] - -testCallInfix :: IO () -testCallInfix = prettyE $ ECall (Symbol "+") [ELit (VInt 7), ELit (VInt 5)] - -testFunBind :: Function -> IO () -testFunBind f = putStrLn (hspp (simplifyParens (functionToHsDecl f))) - -testExportModule :: String -> [Function] -> IO () -testExportModule moduleName fs = - putStrLn (hspp (simplifyParens - (functionsToHsModule moduleName (Functions fs)))) + case M.lookup name operatorTable of + Just op -> Left op + Nothing -> + -- Most names would have the same names in Haskell, + -- but there are a few special cases. + Right (case name of + "zero?" -> "eqZero" + "positive?" -> "gtZero" + "negative?" -> "ltZero" + "add1" -> "succ" + "sub1" -> "pred" + _ -> name) --- | Test export of an example function, specified by name -testEF :: String -> IO () -testEF = testFunBind . getExampleFunction diff --git a/Sifflet/Foreign/ToPython.hs b/Sifflet/Foreign/ToPython.hs --- a/Sifflet/Foreign/ToPython.hs +++ b/Sifflet/Foreign/ToPython.hs @@ -1,12 +1,11 @@ -- | Sifflet to abstract syntax tree for Python. --- Use Python module's pretty to pretty-print the result. +-- Use Python module's pyPretty to pretty-print the result. module Sifflet.Foreign.ToPython ( PythonOptions(..) , defaultPythonOptions , exprToPExpr - , valueToPExpr , nameToPython , fixIdentifierChars , functionToPyDef @@ -20,14 +19,15 @@ import Char (isAlpha, isDigit, ord) import Control.Monad (unless) +import Data.Map ((!)) +import System.Directory (copyFile, doesFileExist) +import System.FilePath (replaceFileName) import Sifflet.Foreign.Exporter import Sifflet.Foreign.Python import Sifflet.Language.Expr -import Sifflet.Text.Pretty - -import System.Directory (copyFile, doesFileExist) -import System.FilePath (replaceFileName) +-- import Sifflet.Text.Pretty +import Sifflet.Util import Paths_sifflet_lib -- Cabal-generated paths module @@ -42,72 +42,70 @@ defaultPythonOptions :: PythonOptions defaultPythonOptions = PythonOptions -exprToPExpr :: Expr -> PExpr +-- A lot of these are "pass-through" -- simplify: *** +exprToPExpr :: Expr -> Expr exprToPExpr expr = case expr of - EUndefined -> var "undefined" - ESymbol (Symbol str) -> var str -- ??? - ELit value -> valueToPExpr value + EUndefined -> EUndefined -- was var "undefined" + ESymbol _ -> expr + + EBool _ -> expr + EChar c -> EString [c] -- Python does not distinguish char from str + ENumber _ -> expr + EString _ -> expr + EIf cond action altAction -> - -- 2 choices here: Python if statement (condS) - -- or Python if expression (condE) - condE (exprToPExpr cond) - (exprToPExpr action) - (exprToPExpr altAction) + -- EIf here represents a Python if *expression*: + -- value if test else altvalue + -- not the familiar if *statement*! + EIf (exprToPExpr cond) + (exprToPExpr action) + (exprToPExpr altAction) EList exprs -> - call "li" (map exprToPExpr exprs) + ECall (Symbol "li") (map exprToPExpr exprs) ECall (Symbol fname) args -> -- Python distinguishes between functions and operators case nameToPython fname of - Left operator -> + Left op -> case args of [left, right] -> - POperate operator - (exprToPExpr left) - (exprToPExpr right) + EOp op (EGroup (exprToPExpr left)) + (EGroup (exprToPExpr right)) _ -> error "exprToPExpr: operation does not have 2 operands" Right pname -> - call pname (map exprToPExpr args) - - -valueToPExpr :: Value -> PExpr -valueToPExpr value = - case value of - VList vs -> call "li" (map valueToPExpr vs) - VBool b -> bool b - VChar c -> char c - VInt i -> pInt i - VFloat x -> pFloat x - VStr s -> string s - VFun f -> var "undefined" -- fix! Is it fixable? *** - -- Scheme: SFunction f + -- I don't think we need (a) for each arg a + -- since they are separated by commas + ECall (Symbol pname) (map exprToPExpr args) + _ -> errcats ["exprToPExpr: extended expr:", show expr] --- | Convert Sifflet name (of a function) to Python name -nameToPython :: String -> Either POperator String +-- | Convert Sifflet name (of a function) to Python operator (Left) +-- or function name (Right) +nameToPython :: String -> Either Operator String nameToPython name = - case name of - "+" -> Left opPlus - "-" -> Left opMinus - "*" -> Left opTimes - "div" -> Left opIDiv - "mod" -> Left opMod - "/" -> Left opFDiv -- invalid for integers in Python 2! - "==" -> Left opEq - "/=" -> Left opNe - ">" -> Left opGt - ">=" -> Left opGe - "<" -> Left opLt - "<=" -> Left opLe - "add1" -> Right "add1" - "sub1" -> Right "sub1" - "zero?" -> Right "eqZero" - "positive?" -> Right "gtZero" - "negative?" -> Right "ltZero" - "null" -> Right "null" - "head" -> Right "head" - "tail" -> Right "tail" - ":" -> Right "cons" - _ -> Right (fixIdentifierChars name) + let oper oname = Left $ operatorTable ! oname + in case name of + "+" -> oper "+" + "-" -> oper "-" + "*" -> oper "*" + "div" -> oper "//" + "mod" -> oper "%" + "/" -> oper "/" -- invalid for integers in Python 2! + "==" -> oper "==" + "/=" -> oper "!=" + ">" -> oper ">" + ">=" -> oper ">=" + "<" -> oper "<" + "<=" -> oper "<=" + "add1" -> Right "add1" + "sub1" -> Right "sub1" + "zero?" -> Right "eqZero" + "positive?" -> Right "gtZero" + "negative?" -> Right "ltZero" + "null" -> Right "null" + "head" -> Right "head" + "tail" -> Right "tail" + ":" -> Right "cons" + _ -> Right (fixIdentifierChars name) -- | Remove characters that are not valid in a Python identifier, -- and in some cases, insert other characters to show what's missing @@ -128,18 +126,25 @@ in fix +-- | Create a Python def statement from a Sifflet function. +-- Minimally parenthesized. functionToPyDef :: Function -> PStatement functionToPyDef = defToPy . functionToDef defToPy :: FunctionDefTuple -> PStatement defToPy (fname, paramNames, _, _, body) = - fun (fixIdentifierChars fname) paramNames (exprToPExpr body) + fun (fixIdentifierChars fname) + paramNames + ((simplifyExpr pyRules) (exprToPExpr body)) +pyRules :: [Expr -> Expr] +pyRules = commonRulesForSimplifyingExprs + functionsToPyModule :: Functions -> PModule functionsToPyModule (Functions fs) = PModule (map functionToPyDef fs) functionsToPrettyPy :: Functions -> String -functionsToPrettyPy = pretty . functionsToPyModule +functionsToPrettyPy = pyPretty . functionsToPyModule exportPython :: PythonOptions -> Exporter exportPython _options funcs path = diff --git a/Sifflet/Foreign/ToScheme.hs b/Sifflet/Foreign/ToScheme.hs --- a/Sifflet/Foreign/ToScheme.hs +++ b/Sifflet/Foreign/ToScheme.hs @@ -23,10 +23,12 @@ import Paths_sifflet_lib -- generated by Cabal +import Data.Number.Sifflet import Sifflet.Foreign.Exporter import Sifflet.Language.Expr import Sifflet.Text.Repr import Sifflet.Text.Pretty +import Sifflet.Util -- Scheme S-exprs -- -------------- @@ -84,8 +86,12 @@ SAtom (SSymbol "*sifflet-undefined*") ESymbol (Symbol str) -> SAtom (SSymbol (functionNameToSchemeName str)) - ELit value -> - valueToSExpr value + + EBool b -> valueToSExpr (VBool b) + EChar c -> valueToSExpr (VChar c) + ENumber n -> valueToSExpr (VNumber n) + EString s -> valueToSExpr (VString s) + EIf cond action altAction -> SList [SAtom (SSymbol "if"), exprToSExpr cond, exprToSExpr action, exprToSExpr altAction] @@ -96,6 +102,7 @@ SList (SAtom (SSymbol "list") : (map exprToSExpr exprs)) ECall fsym args -> SList (exprToSExpr (ESymbol fsym) : map exprToSExpr args) + _ -> errcats ["exprToSExpr: extended expr:", show expr] -- Convert Sifflet function names to corresponding Scheme function names. -- There are a few special cases; otherwise, the names are the same. @@ -133,9 +140,9 @@ SAtom (case value of VBool b -> SBool b VChar c -> SChar c - VInt i -> SInt i - VFloat x -> SFloat x - VStr s -> SString s + VNumber (Exact i) -> SInt i + VNumber (Inexact x) -> SFloat x + VString s -> SString s VFun f -> SFunction f VList _ -> error ("valueToSExpr: Impossible! " ++ diff --git a/Sifflet/Language/Expr.hs b/Sifflet/Language/Expr.hs --- a/Sifflet/Language/Expr.hs +++ b/Sifflet/Language/Expr.hs @@ -1,12 +1,18 @@ module Sifflet.Language.Expr - (stringToExpr, exprToValue, stringToValue - , stringToLiteral + ( + exprToValue, valueToLiteral, valueToLiteral' , Symbol(..) - , OInt, OStr, OBool, OChar, OFloat - , Expr(..), eSymbol, eInt, eString, eChar, eFloat + , OStr, OBool, OChar + , Expr(..), eSymbol, eSym, eInt, eString, eChar, eFloat + , exprIsAtomic + , exprIsCompound , eBool, eFalse, eTrue, eIf , eList, eCall + , exprIsLiteral , exprSymbols, exprVarNames + , Operator(..) + , Precedence + , OperatorGrouping(..) , ExprTree, ExprNode(..), ExprNodeLabel(..) , exprNodeIoletCounter -- needs work ****** get rid of it??? , exprToTree, treeToExpr, exprToReprTree @@ -38,167 +44,162 @@ -- drop this after debugging: import System.IO.Unsafe(unsafePerformIO) --- Try to get rid of these: -import Language.Haskell.Syntax -import Language.Haskell.Parser - - import Data.Map as Map hiding (filter, map, null) import Data.List as List +import Data.Number.Sifflet import Sifflet.Data.Tree as T +import Sifflet.Text.Pretty import Sifflet.Text.Repr () import Sifflet.Util -{-# DEPRECATED stringToExpr "Use Sifflet.Language.Parser.parseExpr or Sifflet.Language.Parser.parseInput instead But stringToExpr is more general, so it may be needed in some cases." #-} - -stringToExpr :: String -> SuccFail Expr -stringToExpr string = - case parseModule ("x = " ++ string) of - ParseOk (HsModule - _srcLoc -- (SrcLoc ...) - _module -- (Module "Main") - _justMain -- (Just [HsEVar (UnQual (HsIdent "main"))]) - _ -- [] - result) - -> - case result of - [HsPatBind _ _ (HsUnGuardedRhs expr) []] -> - hsExpToVp expr - _ -> - errcat ["stringToExpr: unexpected parse result " ++ - "from string " ++ show string ++ - "; result = " ++ show result] - - ParseFailed _ str -> Fail str -- not very informative - -hsExpToVp :: HsExp -> SuccFail Expr -hsExpToVp hsExp = - case hsExp of - - HsVar (UnQual (HsSymbol name)) -> Succ $ eSymbol name -- e.g. "+" - HsVar (UnQual (HsIdent name)) -> Succ $ eSymbol name -- e.g. "head" - - HsLit (HsInt i) -> Succ $ eInt i - HsLit (HsFrac r) -> Succ $ eFloat (fromRational r) - HsLit (HsChar a) -> Succ $ eChar a - HsLit (HsString s) -> Succ $ eString s - - HsCon (UnQual (HsIdent "False")) -> Succ eFalse - HsCon (UnQual (HsIdent "True")) -> Succ eTrue - - HsList items -> - case hsListItemsToVps [] items of - Fail msg -> Fail msg - Succ items' -> Succ (eList items') - - HsNegApp hslit -> hsExpToVp hslit >>= eNegate - - HsApp (HsVar (UnQual (HsIdent name))) hsArg -> - do - arg <- hsExpToVp hsArg - Succ $ eCall name [arg] -- ??? *** - HsApp (HsApp hsApp1 hsArg1) hsArg2 -> - do - call1 <- hsExpToVp (HsApp hsApp1 hsArg1) - arg2 <- hsExpToVp hsArg2 - let ECall f args = call1 - Succ $ ECall f (args ++ [arg2]) - HsInfixApp hsArg1 (HsQVarOp (UnQual (HsSymbol op))) hsArg2 -> - do - arg1 <- hsExpToVp hsArg1 - arg2 <- hsExpToVp hsArg2 - Succ $ eCall op [arg1, arg2] - - HsIf hsExp1 hsExp2 hsExp3 -> - do - expr1 <- hsExpToVp hsExp1 - expr2 <- hsExpToVp hsExp2 - expr3 <- hsExpToVp hsExp3 - Succ $ eIf expr1 expr2 expr3 - - HsParen hsExp1 -> hsExpToVp hsExp1 - - _ -> Fail ("hsExpToVp: unknown expression type: " ++ show hsExp) +-- | Transform a numerical expression into its negation, +-- e.g., 5 --> (-5). +-- Fails if the expression is not an ENumber. eNegate :: Expr -> SuccFail Expr eNegate expr = case expr of - ELit (VInt i) -> Succ $ ELit (VInt (negate i)) - ELit (VFloat x) -> Succ $ ELit (VFloat (negate x)) + ENumber n -> Succ $ ENumber (negate n) _ -> Fail $ "eNegate: cannot handle" ++ show expr -hsListItemsToVps :: [Expr] -> [HsExp] -> SuccFail [Expr] -hsListItemsToVps result items = - case items of - [] -> Succ (reverse result) - (x:xs) -> - case hsExpToVp x of - Fail msg -> Fail msg - Succ x' -> hsListItemsToVps (x':result) xs - -- Symbols have names, and may or may not have values, -- but the value is stored in an environment, not in the symbol itself. data Symbol = Symbol String -- symbol name deriving (Eq, Read, Show) +instance Pretty Symbol where + pretty (Symbol s) = s + instance Repr Symbol where repr (Symbol s) = s --- The Haskell representations of V's primitive data types -type OInt = Integer +-- The Haskell representations of V's primitive data types. +-- Data.Number.Sifflet.Number represents exact and inexact numbers. type OStr = String type OBool = Bool type OChar = Char -type OFloat = Double -stringToLiteral :: String -> SuccFail Expr -stringToLiteral s = stringToValue s >>= valueToLiteral - -- | A more highly "parsed" type of expression -- --- ELit (literals) are "primitive" (self-evaluating) expressions, --- in the sense that if x is a literal, then eval x env = EvalOk x --- for any environment env. -- I've restricted function calls to the case where the function expression -- is just a symbol, since otherwise it will be hard to visualize. -- But with some thought, it may be possible to generalize -- this to -- ECall [Expr] -- (function:args) - +-- The constructors EOp and EGroup are not used in Sifflet itself, +-- but they are needed for export to Python, Haskell, and similar languages; +-- they allow a distinction between operators and functions, and +-- wrapping expressions in parentheses. +-- EGroup e represents parentheses used for grouping: (e); +-- it is not used for other cases of parentheses, e.g., +-- around the argument list in a function call.] + data Expr = EUndefined | ESymbol Symbol - | ELit Value - | EIf Expr Expr Expr -- if test branch1 branch2 - | EList [Expr] -- needed for hsExpToVp case HsList - | ECall Symbol [Expr] -- function name, arglist - deriving (Eq, Read, Show) + | EBool Bool + | EChar Char + | ENumber Number + | EString String + | EIf Expr Expr Expr -- ^ if test branch1 branch2 + | EList [Expr] + | ECall Symbol [Expr] -- ^ function name, arglist + | EOp Operator Expr Expr -- ^ binary operator application + | EGroup Expr -- ^ grouping parentheses + deriving (Eq, Show) instance Repr Expr where - repr EUndefined = "*undefined*" - repr (ESymbol s) = repr s - repr (ELit x) = repr x - repr (EIf t a b) = par "if" (map repr [t, a, b]) - repr (EList items) = par "EList" (map repr items) - repr (ECall (Symbol fname) args) = par fname (map repr args) + repr e = + case e of + EUndefined -> "*undefined*" + ESymbol s -> repr s + EBool b -> repr b + EChar c -> repr c + ENumber n -> repr n + EString s -> show s + EIf t a b -> par "if" (map repr [t, a, b]) + EList xs -> if exprIsLiteral e + then reprList "[" ", " "]" xs + else error ("Expr.repr: EList expression is non-literal: " + ++ show e) + -- check *** was: par "EList" (map repr items) + ECall (Symbol fname) args -> par fname (map repr args) + EOp op left right -> unwords [repr left, opName op, repr right] + EGroup e' -> "(" ++ repr e' ++ ")" -eSymbol :: String -> Expr + +-- | An Expr is "extended" if it uses the extended constructors +-- EOp or EGroup. In pure Sifflet, no extended Exprs are used. + +exprIsExtended :: Expr -> Bool +exprIsExtended e = + case e of + EOp _ _ _ -> True + EGroup _ -> True + EIf t a b -> exprIsExtended t || + exprIsExtended a || + exprIsExtended b + EList xs -> any exprIsExtended xs + ECall (Symbol _) args -> any exprIsExtended args + _ -> False + +-- | Is an Expr a literal? A literal is a boolean, character, number, string, +-- or list of literals. We (should) only allow user input expressions +-- to be literal expressions. + +exprIsLiteral :: Expr -> Bool +exprIsLiteral e = + case e of + EBool _ -> True + EChar _ -> True + ENumber _ -> True + EString _ -> True + EList es -> all exprIsLiteral es + -- Shouldn't we say that + -- EGroup e' *not* a literal, even if e' is a literal? + -- But consider carefully the effect on exprIsAtomic and ()'s removal. + EGroup e' -> True -- or False, or exprIsLiteral e' ??? + _ -> False + +-- | Is an expression atomic? +-- Atomic expressions do not need parentheses in any reasonable language, +-- because there is nothing to be grouped (symbols, literals) +-- or in the case of lists, they already have brackets +-- which separate them from their neighbors. +-- +-- All lists are atomic, even if they are not literals, +-- because (for example) we can remove parentheses +-- from ([a + b, 7]) + +exprIsAtomic :: Expr -> Bool +exprIsAtomic e = + case e of + ESymbol _ -> True + EList _ -> True + _ -> exprIsLiteral e + +-- | Compound = non-atomic +exprIsCompound :: Expr -> Bool +exprIsCompound = not . exprIsAtomic + +eSymbol, eSym :: String -> Expr eSymbol = ESymbol . Symbol +eSym = eSymbol -eInt :: OInt -> Expr -eInt = ELit . VInt +eInt :: Integer -> Expr +eInt = ENumber . Exact eString :: OStr -> Expr -eString = ELit . VStr +eString = EString eChar :: OChar -> Expr -eChar = ELit . VChar +eChar = EChar -eFloat :: OFloat -> Expr -eFloat = ELit . VFloat +eFloat :: Double -> Expr +eFloat = ENumber . Inexact eBool :: Bool -> Expr -eBool = ELit . VBool +eBool = EBool eFalse, eTrue :: Expr eFalse = eBool False @@ -215,13 +216,44 @@ eCall :: String -> [Expr] -> Expr eCall = ECall . Symbol +-- | An operator, such as * or + +-- An operator is associative, like +, if (a + b) + c == a + (b + c). +-- Its grouping is left to right if (a op b op c) means (a op b) op c; +-- right to left if (a op b op c) means a op (b op c). +-- Most operators group left to right. +data Operator = Operator {opName :: String + , opPrec :: Precedence + , opAssoc :: Bool -- ^ associative? + , opGrouping :: OperatorGrouping + } + deriving (Eq, Show) +instance Pretty Operator where + pretty = opName + +-- | Operator priority, normally is > 0 or >= 0, +-- but does that really matter? I think not. +type Precedence = Int + +-- | Operator grouping: left to right or right to left, +-- or perhaps not at all +data OperatorGrouping = GroupLtoR | GroupRtoL | GroupNone + deriving (Eq, Show) + +-- | -- EXPRESSION TREES +-- For pure Sifflet, so not defined for extended expressions. + type ExprTree = Tree ExprNode data ExprNode = ENode ExprNodeLabel EvalResult deriving (Eq, Show) -data ExprNodeLabel = NUndefined | NSymbol Symbol | NLit Value +data ExprNodeLabel = NUndefined | NSymbol Symbol + | + -- formerly NLit Value + NBool Bool | NChar Char | NNumber Number + | NString String + | NList [Expr] -- ??? deriving (Eq, Show) instance Repr ExprNode where @@ -239,8 +271,14 @@ EvalOk v -> [repr s, repr v] EvalError e -> [repr s, "error: " ++ e] EvalUntried -> reprl s - NLit l -> reprl l + -- NLit l -> reprl l + NBool b -> reprl b + NChar c -> reprl c + NNumber n -> reprl n + NString s -> [show s] + NList es -> reprl (EList es) -- check *** + -- This was -- exprNodeIoletCounter :: Env -> IoletCounter ExprNode -- but IoletCounter is not available here, so use equivalent type. @@ -257,26 +295,38 @@ case value of VFun function -> (functionNArgs function, 1) _ -> (0, 1) -- symbol bound to non-function value - NLit _ -> (0, 1) + _ -> (0, 1) exprToTree :: Expr -> ExprTree exprToTree expr = - case expr of - -- EUndefined, ESymbol, ELit map direclty to NUndefined, NSymbol, NLit - EUndefined -> T.Node (ENode NUndefined EvalUntried) [] - ESymbol s -> T.Node (ENode (NSymbol s) EvalUntried) [] - ELit l -> T.Node (ENode (NLit l) EvalUntried) [] - -- EIf maps to symbol "if" at the root, 3 subtrees - EIf t a b -> T.Node (ENode (NSymbol (Symbol "if")) EvalUntried) - (map exprToTree [t, a, b]) - -- ECall maps to symbol f (function name) at the root, - -- each argument forms a subtree - ECall f args -> T.Node (ENode (NSymbol f) EvalUntried) - (map exprToTree args) - -- EList maps to the *symbol* (yes!) "[]" or to a ":" (cons) expression - EList [] -> T.Node (ENode (NSymbol (Symbol "[]")) EvalUntried) [] - EList (x:xs) -> exprToTree (ECall (Symbol ":") [x, EList xs]) + let leafnode :: ExprNodeLabel -> T.Tree ExprNode + leafnode e = node e [] + node :: ExprNodeLabel -> [T.Tree ExprNode] -> T.Tree ExprNode + node e ts = T.Node (ENode e EvalUntried) ts + errext = error ("exprToTree: extended expr: " ++ show expr) + in case expr of + -- EUndefined, ESymbol, and literals map directly + -- to NUndefined, NSymbol, E(literal-type) + EUndefined -> leafnode NUndefined + ESymbol s -> leafnode (NSymbol s) + -- Literals + EBool b -> leafnode (NBool b) + EChar c -> leafnode (NChar c) + ENumber n -> leafnode (NNumber n) + EString s -> leafnode (NString s) + + -- EIf maps to symbol "if" at the root, 3 subtrees + EIf t a b -> node (NSymbol (Symbol "if")) (map exprToTree [t, a, b]) + + -- ECall maps to symbol f (function name) at the root, + -- each argument forms a subtree + ECall f args -> node (NSymbol f) (map exprToTree args) + EList xs -> leafnode (NList xs) + -- Extended Exprs not supported! + EGroup _ -> errext + EOp _ _ _ -> errext + -- | Convert an expression tree (back) to an expression -- It will not give back the *same* expression in the case of an EList. treeToExpr :: ExprTree -> Expr @@ -284,8 +334,15 @@ let wrong msg = errcat ["treeToExpr: ", msg, ": node label = ", show label, "; trees = ", show trees] + lit e = if null trees then e + else wrong "literal node with non-empty subtrees" in case label of NUndefined -> EUndefined + NBool b -> lit (EBool b) + NChar c -> lit (EChar c) + NNumber n -> lit (ENumber n) + NString s -> lit (EString s) + NList xs -> lit (EList xs) NSymbol s -> if s == Symbol "if" then case trees of @@ -300,8 +357,6 @@ ESymbol s else -- s = function symbol in function call ECall s (map treeToExpr trees) - NLit lit -> if null trees then ELit lit - else wrong "literal node with non-empty subtrees" -- Convert an expression to a repr tree (of string elements) -- (Why?) @@ -377,20 +432,18 @@ data Value = VBool OBool | VChar OChar - | VInt OInt - | VFloat OFloat - | VStr OStr + | VNumber Number + | VString OStr | VFun Function | VList [Value] - deriving (Eq, Read, Show) + deriving (Eq, Show) -- no Read for Function instance Repr Value where repr (VBool b) = show b repr (VChar c) = show c - repr (VInt i) = show i - repr (VFloat x) = show x - repr (VStr s) = show s + repr (VNumber n) = show n + repr (VString s) = show s repr (VFun f) = show f repr (VList vs) = reprList "[" ", " "]" vs @@ -412,16 +465,40 @@ valueToLiteral :: Value -> SuccFail Expr valueToLiteral v = case v of - VFun _f -> Fail "cannot convert a function to a literal" - _ -> Succ (ELit v) - -stringToValue :: String -> SuccFail Value -stringToValue s = - -- take a shortcut here? - case stringToExpr s of - Succ expr -> exprToValue expr - Fail errmsg -> Fail errmsg + VBool b -> Succ $ EBool b + VChar c -> Succ $ EChar c + VNumber n -> Succ $ ENumber n + VString s -> Succ $ EString s + -- VList [] -> Succ $ EList [] + -- VV Should this be fixed? VV + -- VList _ -> Fail "cannot convert non-empty list to literal expression" + VList vs -> mapM valueToLiteral vs >>= Succ . EList + VFun _f -> Fail "cannot convert function to literal expression" +valueToLiteral' :: Value -> Expr +valueToLiteral' v = case valueToLiteral v of + Fail msg -> error ("valueToLiteral: " ++ msg) + Succ e -> e + +-- | Convert a literal expression to the value it represents. +-- It is an error if the expression is non-literal. +-- See exprIsLiteral. +literalToValue :: Expr -> Value +literalToValue e = + case e of + EBool b -> VBool b + EChar c -> VChar c + ENumber n -> VNumber n + EString s -> VString s + EList es -> if exprIsLiteral e + then VList (map literalToValue es) + else errcats ["literalToValue: ", + "non-literal list expression: ", + show e] + _ -> errcats ["literalToValue: non-literal or extended expression: " , + show e] + + data VpType = VpTypeBool | VpTypeChar | VpTypeNum @@ -429,7 +506,7 @@ | VpTypeList VpType -- list with fixed type of elements | VpTypeFunction [VpType] VpType -- argument, result types | VpTypeVar String -- named type variable - deriving (Eq, Read, Show) + deriving (Eq, Show) type TypeEnv = Map String VpType @@ -450,10 +527,9 @@ (VpTypeBool, x) -> sorry x "True or False" (VpTypeChar, VChar _) -> Succ env (VpTypeChar, x) -> sorry x "character" - (VpTypeNum, VInt _) -> Succ env - (VpTypeNum, VFloat _) -> Succ env + (VpTypeNum, VNumber _) -> Succ env (VpTypeNum, x) -> sorry x "number" - (VpTypeString, VStr _) -> Succ env + (VpTypeString, VString _) -> Succ env (VpTypeString, x) -> sorry x "string" -- VV Harder -- VV Are the avalues below supposed to be equal to the value above? @@ -483,9 +559,8 @@ case v of VBool _ -> Succ VpTypeBool VChar _ -> Succ VpTypeChar - VInt _ -> Succ VpTypeNum - VFloat _ -> Succ VpTypeNum - VStr _ -> Succ VpTypeString + VNumber _ -> Succ VpTypeNum + VString _ -> Succ VpTypeString VFun (Function _ atypes rtype _) -> Succ $ VpTypeFunction atypes rtype VList [] -> Succ $ VpTypeList $ VpTypeVar "list_element" @@ -524,7 +599,7 @@ [VpType] -- argument types VpType -- result type FunctionImpl -- implementation - deriving (Read, Show) + deriving (Show) data FunctionImpl = Primitive ([Value] -> EvalResult) -- a Haskell function | Compound [String] Expr -- arguments, body @@ -760,7 +835,10 @@ Nothing -> EvalError $ "unbound variable: " ++ name Just value -> EvalOk value - ELit value -> EvalOk value + EBool b -> EvalOk (VBool b) + EChar c -> EvalOk (VChar c) + ENumber n -> EvalOk (VNumber n) + EString n -> EvalOk (VString n) EIf t a b -> case evalWithLimit t env stacksize' of @@ -789,7 +867,9 @@ EvalOk values -> EvalOk (VList values) EvalError e -> EvalError e EvalUntried -> EvalUntried - + _ -> errcats ["evalWithLimit: extended expression not supported", + show expr] + -- | Apply a function fvalue to a list of actual arguments args -- in an environment env and with a limited stack size stacksize apply :: Value -> [Value] -> Env -> Int -> EvalResult @@ -839,27 +919,27 @@ primitiveFunctions :: [Function] primitiveFunctions = [ -- Arithmetic - primN2N "+" (+) (+), -- Integer (+), Double (+) - primN2N "-" (-) (-), - primN2N "*" (*) (*), + primN2N "+" (+), -- Number (+) + primN2N "-" (-), + primN2N "*" (*), primIntDiv, primIntMod, primFloatDiv, - primN1N "add1" succ succ, - primN1N "sub1" pred pred, + primN1N "add1" succ, + primN1N "sub1" pred, -- Comparison - primN2B "==" (==) (==), - primN2B "/=" (/=) (/=), - primN2B ">" (>) (>), - primN2B ">=" (>=) (>=), - primN2B "<" (<) (<), - primN2B "<=" (<=) (<=), + primN2B "==" (==), + primN2B "/=" (/=), + primN2B ">" (>), + primN2B ">=" (>=), + primN2B "<" (<), + primN2B "<=" (<=), - primN1B "zero?" (== 0) (== 0.0), - primN1B "positive?" (> 0) (> 0.0), - primN1B "negative?" (< 0) (< 0.0), + primN1B "zero?" eqZero, + primN1B "positive?" gtZero, + primN1B "negative?" ltZero, -- List operations @@ -890,18 +970,18 @@ -- Using an inexact (floating point) argument is an error, -- even if the argument is "equal" to an integer (e.g., 5.0). -- Division (div or mod) by zero is an error. -primIntDivMod :: String -> (OInt -> OInt -> OInt) -> Function +primIntDivMod :: String -> (Number -> Number -> Number) -> Function primIntDivMod name oper = let func args = let err msg = EvalError $ concat [name, ": ", msg, " (", show args, ")"] in case args of - [VInt a, VInt b] -> + [VNumber a, VNumber b] -> if b == 0 then err "zero divisor" - else EvalOk $ VInt (oper a b) - [VFloat _, _] -> err "arguments must be exact numbers" - [_, VFloat _] -> err "arguments must be exact numbers" + else if isExact a && isExact b + then EvalOk $ VNumber (oper a b) + else err "arguments must be exact numbers" _ -> error "wrong type or number of arguments" in prim name [VpTypeNum, VpTypeNum] VpTypeNum func @@ -918,11 +998,7 @@ primFloatDiv = let divide args = case args of - [VInt ix, VInt iy] -> - EvalOk $ VFloat (fromIntegral ix / fromIntegral iy) - [VInt ix, VFloat y] -> EvalOk $ VFloat (fromIntegral ix / y) - [VFloat x, VInt iy] -> EvalOk $ VFloat (x / fromIntegral iy) - [VFloat x, VFloat y] -> EvalOk $ VFloat (x / y) + [VNumber x, VNumber y] -> EvalOk $ VNumber (x / y) _ -> EvalError $ "/: invalid args: " ++ show args in prim "/" [VpTypeNum, VpTypeNum] VpTypeNum divide @@ -969,51 +1045,40 @@ -- Functions for constructing Functions of common types -- | Primitive function with 2 number arguments yield an number value --- fi = integer function to implement for integer operands. --- fx = float function to implement for float operands. -primN2N :: String -> (OInt -> OInt -> OInt) -> (OFloat -> OFloat -> OFloat) - -> Function -primN2N name fi fx = +-- fn = Number function to implement for Number operands. +primN2N :: String -> (Number -> Number -> Number) -> Function +primN2N name fn = let impl args = case args of - [VInt ix, VInt iy] -> EvalOk $ VInt (fi ix iy) - [VInt ix, VFloat y] -> EvalOk $ VFloat (fx (fromIntegral ix) y) - [VFloat x, VInt iy] -> EvalOk $ VFloat (fx x (fromIntegral iy)) - [VFloat x, VFloat y] -> EvalOk $ VFloat (fx x y) + [VNumber x, VNumber y] -> EvalOk $ VNumber (fn x y) _ -> EvalError $ name ++ ": invalid args: " ++ show args in prim name [VpTypeNum, VpTypeNum] VpTypeNum impl -- | Primitive unary functions number to number -primN1N :: String -> (OInt -> OInt) -> (OFloat -> OFloat) -> Function -primN1N name fi fx = +primN1N :: String -> (Number -> Number) -> Function +primN1N name fn = let impl args = case args of - [VInt ix] -> EvalOk $ VInt (fi ix) - [VFloat x] -> EvalOk $ VFloat (fx x) + [VNumber x] -> EvalOk $ VNumber (fn x) _ -> EvalError $ name ++ ": invalid args: " ++ show args in prim name [VpTypeNum] VpTypeNum impl -- Primitive frunctions with 2 number args and a boolean result -primN2B :: String -> (OInt -> OInt -> OBool) -> (OFloat -> OFloat -> OBool) - -> Function -primN2B name fi fx = +primN2B :: String -> (Number -> Number -> OBool) -> Function +primN2B name fn = let impl args = case args of - [VInt x, VInt y] -> EvalOk $ VBool (fi x y) - [VInt ix, VFloat y] -> EvalOk $ VBool (fx (fromIntegral ix) y) - [VFloat x, VInt iy] -> EvalOk $ VBool (fx x (fromIntegral iy)) - [VFloat x, VFloat y] -> EvalOk $ VBool (fx x y) + [VNumber x, VNumber y] -> EvalOk $ VBool (fn x y) _ -> EvalError $ name ++ ": invalid args: " ++ show args in prim name [VpTypeNum, VpTypeNum] VpTypeBool impl -- Primitive unary functions number to boolean -primN1B :: String -> (OInt -> Bool) -> (OFloat -> OBool) -> Function -primN1B name fi fx = +primN1B :: String -> (Number -> Bool) -> Function +primN1B name fn = let impl args = case args of - [VInt ix] -> EvalOk $ VBool (fi ix) - [VFloat x] -> EvalOk $ VBool (fx x) + [VNumber x] -> EvalOk $ VBool (fn x) _ -> EvalError $ name ++ ": invalid args: " ++ show args in prim name [VpTypeNum] VpTypeBool impl @@ -1029,7 +1094,6 @@ nub $ case expr of EUndefined -> [] -- is *not* a variable ESymbol s -> [s] - ELit _ -> [] EIf t a b -> nub $ concat [exprSymbols t, exprSymbols a, exprSymbols b] @@ -1039,6 +1103,10 @@ a:as -> nub $ concat [exprSymbols a, exprSymbols (ECall f as)] EList items -> nub $ concatMap exprSymbols items + _ -> if exprIsExtended expr + then errcats ["exprSymbols: extended expr not supported:", + show expr] + else [] -- literal types bool, char, number, string -- | exprVarNames expr returns the names of variables in expr -- that are UNBOUND in the base environment. This may not be ideal, diff --git a/Sifflet/Language/Parser.hs b/Sifflet/Language/Parser.hs --- a/Sifflet/Language/Parser.hs +++ b/Sifflet/Language/Parser.hs @@ -10,11 +10,15 @@ -- ESymbol, EIf, and ECall. module Sifflet.Language.Parser - (parseExpr, parseInput - -- , parseInputAsValue + (parseExpr + , parseValue + , parseLiteral , parseTest - , parseSuccFail, nothingBut - , expr, list, literal + , parseSuccFail + , parseTypedInput2, parseTypedInputs2 + , parseTypedInput3, parseTypedInputs3 + , nothingBut + , expr, list , value, typedValue , bool, qchar, qstring, integer, double , number @@ -24,26 +28,67 @@ import Text.ParserCombinators.Parsec +import Data.Number.Sifflet import Sifflet.Language.Expr import Sifflet.Util - --- | Parse a Sifflet data literal (number, string, char, bool, or list) +-- | Parse a Sifflet data literal (number, string, char, bool, or list), +-- returning an Expr parseExpr :: String -> SuccFail Expr parseExpr = parseSuccFail expr --- | Parse a Sifflet input containing exactly one data expression --- possibly flanked by white space -parseInput :: String -> SuccFail Expr -parseInput = parseSuccFail input +-- | Parse a Sifflet literal expression and return its Value +parseValue :: String -> SuccFail Value +parseValue s = + -- take a shortcut here? + -- case parseExpr s of -- stringToExpr s of + -- Succ expr -> exprToValue expr + -- Fail errmsg -> Fail errmsg + parseLiteral s >>= exprToValue +parseLiteral :: String -> SuccFail Expr +parseLiteral s = + -- parseValue s >>= valueToLiteral + case parseExpr s of + Succ e -> if exprIsLiteral e + then Succ e + else Fail $ + "parseLiteral: expr is non-literal" ++ show e + Fail errmsg -> Fail errmsg + parseSuccFail :: Parser a -> String -> SuccFail a parseSuccFail p s = case parse p "user input" s of Left perr -> Fail (show perr) Right v -> Succ v +-- | Try to parse an input value of a specific type +parseTypedInput2 :: (String, VpType) -> SuccFail Value +parseTypedInput2 (str, vartype) = + parseSuccFail (nothingBut (typedValue vartype)) str +-- | Try to parse input values of specific types +parseTypedInputs2 :: [String] -- ^ input strings + -> [VpType] -- ^ expected types + -> SuccFail [Value] +parseTypedInputs2 strs vartypes = + mapM parseTypedInput2 (zip strs vartypes) + +-- | Try to parse an input value for a named variable of a specific type +parseTypedInput3 :: (String, String, VpType) -> SuccFail Value +parseTypedInput3 (s, varname, vartype) = + case parseSuccFail (nothingBut (typedValue vartype)) s of + Fail msg -> Fail ("For variable " ++ varname ++ ":\n" ++ msg) + Succ v -> Succ v + +-- | Try to parse input values for named variables of specific types +parseTypedInputs3 :: [String] -- ^ inputs + -> [String] -- ^ variable names + -> [VpType] -- ^ variable types + -> SuccFail [Value] +parseTypedInputs3 strs varnames vartypes = + mapM parseTypedInput3 (zip3 strs varnames vartypes) + -- | Like expr, but consumes the entire input, -- so there must not be any extraneous characters after the Expr. input :: Parser Expr @@ -58,10 +103,16 @@ prog1 :: (Monad m) => m a -> m b -> m a prog1 m1 m2 = m1 >>= (\ r -> m2 >> return r) --- | Parse a Sifflet data expression +-- | Parse a Sifflet data expression -- actually only a literal +-- or a list of literals. expr :: Parser Expr expr = -- (try (list expr >>= return . EList)) <|> - literal + (bool >>= return . EBool) <|> + (qchar >>= return . EChar) <|> + (qstring >>= return . EString) <|> + try (double >>= return . ENumber . Inexact) <|> + (integer >>= return . ENumber . Exact) <|> + (list expr >>= return . EList) list :: Parser a -> Parser [a] list element = @@ -73,35 +124,30 @@ "list" -- ??? -literal :: Parser Expr -literal = value >>= return . ELit + -- | Parser for a Value of any type (any VpType), -- except that we cannot parse as VpTypeVar or VpTypeFunction. value :: Parser Value value = (bool >>= return . VBool) <|> (qchar >>= return .VChar) <|> - (qstring >>= return . VStr) <|> - try (double >>= return . VFloat) <|> - (integer >>= return . VInt) <|> + (qstring >>= return . VString) <|> + try (double >>= return . VNumber . Inexact) <|> + (integer >>= return . VNumber . Exact) <|> (list value >>= return . VList) -- | Parser for a value with a specific VpType expected. -- Again, we cannot do this for VpTypeVar (why not?) --- or VpTypeFunctiopn +-- or VpTypeFunction typedValue :: VpType -> Parser Value typedValue t = (case t of VpTypeBool -> bool >>= return . VBool VpTypeChar -> qchar >>= return . VChar - VpTypeString -> qstring >>= return . VStr - VpTypeNum -> do { en <- number; - case en of - Left x -> return (VFloat x) - Right i -> return (VInt i) - } + VpTypeString -> qstring >>= return . VString + VpTypeNum -> number >>= return . VNumber VpTypeList e -> list (typedValue e) >>= return . VList VpTypeVar _ -> value -- can't check, so just accept anything VpTypeFunction _ _ -> @@ -177,21 +223,6 @@ ) ) - -- do { _ <- char bs; - -- c <- oneOf "ntr\\" - -- - -- "n, t, r, or \\ to follow \\"; - -- return (case c of - -- 'n' -> '\n' - -- 't' -> '\t' - -- 'r' -> '\r' - -- '\\' -> '\\' - -- _ -> error "escapedChar: c MUST be n, t, r, or \\" - -- ) - -- } - - - data Sign = Minus | Plus -- Integer ::= (+|-)? digit+ @@ -265,24 +296,14 @@ } "real number" --- A number may be either a double (with decimal point) or an integer (without). --- To avoid consuming "123" from "123." and interpreting it as an integer, --- we MUST try to parse double before integer. -number :: Parser (Either Double Integer) -number = (try (double >>= return . Left) <|> - (integer >>= return . Right)) +-- A number is a Sifflet Number, which is exact unless it contains +-- a decimal point. +-- To avoid consuming "123" from "123." and interpreting it as an exact +-- number, we MUST try to parse double before integer. +number :: Parser Number +number = (try (double >>= return . Inexact) <|> + (integer >>= return . Exact)) typeName VpTypeNum --- -- numberValue :: Parser Value --- -- numberValue = do { x <- number; --- -- case x of --- -- value :: Parser Value --- value = (bool >>= return . VBool) <|> --- (qchar >>= return . VChar) - --- Left dx -> return (VFloat dx) --- -- Right ix -> return (VInt ix) --- -- } --- -- typeName VpTypeNumber diff --git a/Sifflet/Language/SiffML.hs b/Sifflet/Language/SiffML.hs --- a/Sifflet/Language/SiffML.hs +++ b/Sifflet/Language/SiffML.hs @@ -8,15 +8,16 @@ , produceSiffMLFile , consumeSiffMLFile , xmlToFunctions - -- , testOut -- testing - -- , xmlToX -- testing - -- , testIn, testFromFile -- testing + -- for testing + , testFromXml +-- , consumeString ) where import Text.XML.HXT.Arrow +import Data.Number.Sifflet import Sifflet.Language.Expr import Sifflet.Util @@ -70,25 +71,63 @@ exprToXml :: Expr -> XMLProducer exprToXml expr = - case expr of - EUndefined -> - eelem "undefined" - ESymbol (Symbol name) -> - selem "symbol" [txt name] - -- To simplify, collapse 2.5 - -- to 2.5, and similarly with other - -- literal values? - ELit value -> - selem "literal" [toXml value] - EIf e1 e2 e3 -> - selem "if" [toXml e1, toXml e2, toXml e3] - EList xs -> - selem "list" (map toXml xs) - ECall (Symbol name) xs -> - selem "call" - (selem "symbol" [txt name] : - map toXml xs) + let literal label text = + -- future: (omit label arg.): selem label [txt text] + selem "literal" [selem label [txt text]] + in case expr of + EUndefined -> + eelem "undefined" + ESymbol (Symbol name) -> + selem "symbol" [txt name] + -- "Literals" + -- New way: duplicates parts of valueToXml (bad) *** + EBool b -> + -- future: selem "bool" [eelem (show b)] + selem "literal" [selem "bool" [eelem (show b)]] + EChar c -> + -- future: selem "char" [txt [c]] + literal "char" [c] + ENumber (Exact i) -> + -- future: selem "int" [txt (show i)] + literal "int" (show i) + ENumber (Inexact x) -> + -- future: selem "float" [txt (show x)] + literal "float" (show x) + EString s -> + -- future: selem "string" [txt s] + literal "string" s + + EIf e1 e2 e3 -> + selem "if" [toXml e1, toXml e2, toXml e3] + EList xs -> + -- I predict that this is going to be troublesome! *** + -- No checking for whether the list elements are literals! + selem "literal" [selem "list" + (map (toXml . literalToValue) xs)] + -- future: selem "list" (map toXml xs) + ECall (Symbol name) xs -> + selem "call" + (selem "symbol" [txt name] : + map toXml xs) + _ -> errcats ["exprToXml: extended expr:", show expr] + +-- | Convert a literal expression to a value. +-- It is an error if the expr is not a literal. +-- Compare exprToValue in Expr.hs +literalToValue :: Expr -> Value +literalToValue e = + if exprIsLiteral e + then case e of + EBool b -> VBool b + EChar c -> VChar c + ENumber n -> VNumber n + EString s -> VString s + EList es -> VList (map literalToValue es) + EGroup e' -> literalToValue e' + _ -> error "literalToValue: expr is literal, but not literal?" + else error ("literalToValue: expr is not a literal: " ++ show e) + xmlToExpr :: XMLConsumer XmlTree Expr xmlToExpr = isElem >>> @@ -96,10 +135,45 @@ (hasName "undefined" >>> constA EUndefined) <+> (hasName "symbol" >>> getChildren >>> isText >>> getText >>> arr (ESymbol . Symbol)) <+> - (hasName "literal" >>> getChildren >>> xmlToValue >>> arr ELit) <+> + + -- future: remove extra level "literal" + (hasName "literal" >>> getChildren >>> xmlToExpr) <+> + + -- boolean values + (hasName "True" >>> constA (EBool True)) <+> + (hasName "False" >>> constA (EBool False)) <+> + + -- chars + (hasName "char" >>> getChildren >>> isText >>> getText >>> + -- VVV head dangerous ??? + arr (EChar . head)) <+> + + -- numbers -- why not use parser instead of read??? + (hasName "int" >>> getChildren >>> isText >>> getText >>> + arr (ENumber . Exact . read)) <+> -- read dangerous? + (hasName "float" >>> getChildren >>> isText >>> getText >>> + arr (ENumber . Inexact . read)) <+> -- read dangerous? + + -- strings + (hasName "string" >>> getChildren >>> isText >>> getText >>> + arr EString) <+> + + (hasName "if" >>> listA (getChildren >>> xmlToExpr) >>> + -- sometimes I get bogus run-time errors here about + -- this pattern [a, b, c] being non-exhaustive. + -- Of course, it *is* non-exhaustive; but it is + -- never violated in practice arr (\ [a, b, c] -> EIf a b c)) <+> - (hasName "list" >>> listA (getChildren >>> xmlToExpr) >>> arr EList) <+> + -- This is very awkward, but needed for compatibility with the + -- present SiffML doctype: + (hasName "list" >>> + -- future?: listA (getChildren >>> xmlToExpr) >>> + -- Anyway, *why* does this not work??? + listA (getChildren >>> xmlToExpr) >>> + -- past?: + -- listA (getChildren >>> xmlToValue >>> arr valueToLiteral') >>> + arr EList) <+> -- VVV Would be less awkward if ECall :: Symbol -> [Expr] -> Expr -- were changed to ECall :: Expr -> [Expr] -> Expr (hasName "call" >>> listA (getChildren >>> xmlToExpr) >>> @@ -107,10 +181,12 @@ ) -- | Values +-- Still used in exprToXml in the EList case :-( instance ToXml Value where toXml = valueToXml +-- Is this still needed? *** valueToXml :: Value -> XMLProducer valueToXml value = case value of @@ -120,11 +196,11 @@ eelem (show b) VChar c -> selem "char" [txt [c]] - VStr s -> + VString s -> selem "string" [txt s] - VInt i -> + VNumber (Exact i) -> selem "int" [txt (show i)] - VFloat x -> + VNumber (Inexact x) -> selem "float" [txt (show x)] -- Are VFun and VList needed??? VFun f -> @@ -132,6 +208,7 @@ VList vs -> selem "list" (map toXml vs) +-- xmlToValue: still needed? *** xmlToValue :: XMLConsumer XmlTree Value xmlToValue = isElem >>> @@ -140,12 +217,12 @@ (hasName "char" >>> getChildren >>> isText >>> getText >>> arr (VChar . head)) <+> (hasName "string" >>> getChildren >>> isText >>> getText >>> - arr VStr) <+> + arr VString) <+> (hasName "int" >>> getChildren >>> isText >>> getText >>> - arr (VInt . read)) -- dangerous? + arr (VNumber . Exact . read)) -- dangerous? <+> (hasName "float" >>> getChildren >>> isText >>> getText >>> - arr (VFloat . read)) -- dangerous? + arr (VNumber . Inexact . read)) -- dangerous? <+> (hasName "function" >>> getChildren >>> xmlToFunction >>> arr VFun) @@ -330,20 +407,22 @@ -- UNUSED: --- -- | testFromXml :: (ToXml a, Show a) => a -> XMLConsumer XmlTree a -> IO () --- -- VVV This type generalization (a, a to a, b) is for debugging, undo it later: --- testFromXml :: (ToXml a, Show b) => a -> XMLConsumer XmlTree b -> IO () --- testFromXml src consumer = do --- { --- produceSiffMLFile src "test.xml" --- ; results <- runX (readDocument defaultOptions "test.xml" >>> --- isElem >>> -- document root --- getChildren >>> --- consumer) --- ; case results of --- [] -> putStrLn "Failed" --- result : _ -> print result --- } +-- | testFromXml :: (ToXml a, Show a) => a -> XMLConsumer XmlTree a -> IO () +-- VVV This type generalization (a, a to a, b) is for debugging, undo it later: +testFromXml :: (ToXml a, Show b) => Int -> a -> XMLConsumer XmlTree b -> IO () +testFromXml traceLevel src consumer = do + { + produceSiffMLFile src "test.xml" + ; results <- runX (readDocument + (defaultOptions ++ [(a_trace, show traceLevel)]) + "test.xml" >>> + isElem >>> -- document root + getChildren >>> + consumer) + ; case results of + [] -> putStrLn "Failed" + result : _ -> print result + } -- testToXmlAndBack :: (ToXml a, Show a) => a -> XMLConsumer XmlTree a -> IO () -- testToXmlAndBack = testFromXml @@ -360,18 +439,7 @@ -- testXmlToSymbol sym = testFromXml sym xmlToSymbol --- exampleIfExpr :: Expr --- exampleIfExpr = (EIf (ELit (VBool False)) -- (eCall ">" [eInt 32, eInt 61]) --- (ELit (VStr "yes")) --- (ELit (VStr "no"))) --- exampleListExpr :: Expr --- exampleListExpr = EList [ELit (VInt 1), ELit (VInt 2), ELit (VInt 3)] - --- exampleCallExpr :: Expr --- exampleCallExpr = ECall (Symbol "foo") [ESymbol (Symbol "x"), ELit (VInt 2)] - - -- produceStdout :: (ToXml a) => a -> IO () -- produceStdout src = produceSiffMLFile src "-" @@ -397,7 +465,3 @@ -- consumeStdin :: XMLConsumer XmlTree a -> IO [a] -- consumeStdin fromXml = consumeSiffMLFile fromXml "-" - - --- exampleVList :: Value --- exampleVList = VList [VInt 32, VInt 64, VInt 69] diff --git a/Sifflet/Text/Pretty.hs b/Sifflet/Text/Pretty.hs --- a/Sifflet/Text/Pretty.hs +++ b/Sifflet/Text/Pretty.hs @@ -1,7 +1,7 @@ module Sifflet.Text.Pretty (Pretty(..) , indentLine, sepLines, sepLines2 - , sepComma, sepCommaSp) + , sepComma, sepCommaSp, sepSpace) where @@ -9,6 +9,10 @@ -- | The class of types that can be pretty-printed. +-- (Unfortunately this is not very useful, because +-- and Expr can be pretty Haskell or pretty Python or pretty Scheme, +-- leading to overlapping instance declarations.) +-- -- pretty x is a pretty String representation of x. -- prettyList prefix infix postfix xs is a pretty String representation -- of the list xs, with prefix, infix, and postfix specifying the @@ -46,3 +50,7 @@ -- | Separate strings by commas and spaces (", ") sepCommaSp :: [String] -> String sepCommaSp = intercalate ", " + +-- | Separate strings by just spaces (" ") +sepSpace :: [String] -> String +sepSpace = unwords diff --git a/Sifflet/Text/Repr.hs b/Sifflet/Text/Repr.hs --- a/Sifflet/Text/Repr.hs +++ b/Sifflet/Text/Repr.hs @@ -5,6 +5,7 @@ where +import Data.Number.Sifflet import Data.List (intercalate) -- | class Repr: representable by a String or a list of Strings @@ -43,11 +44,13 @@ reprList pre tween post xs = pre ++ intercalate tween (map repr xs) ++ post +instance Repr Bool where repr = show +instance Repr Char where repr = show instance Repr Int where repr = show instance Repr Integer where repr = show +instance Repr Number where repr = show instance Repr Float where repr = show instance Repr Double where repr = show -instance Repr Char where repr = show -- instance Repr String won't work because String is a type synonym, -- unless you ask ghc nicely, which I'd prefer not to do. diff --git a/Sifflet/UI/Canvas.hs b/Sifflet/UI/Canvas.hs --- a/Sifflet/UI/Canvas.hs +++ b/Sifflet/UI/Canvas.hs @@ -860,16 +860,10 @@ Nothing -> "" Just v -> repr v defaults = map (argDefault (cfEnv frame)) varnames - parseTypedInput :: (String, String, VpType) -> SuccFail Value - parseTypedInput (s, varname, vartype) = - case parseSuccFail (nothingBut (typedValue vartype)) s of - Fail msg -> - Fail ("For variable " ++ varname ++ ":\n" ++ msg) - Succ v -> Succ v + reader :: Reader [String] [Value] - reader inputs = - mapM parseTypedInput -- parseInputAsTypedValue' - (zip3 inputs varnames (functionArgTypes function)) + reader inputs = parseTypedInputs3 inputs varnames + (functionArgTypes function) in do dialog <- createEntryDialog "Input Values" varnames defaults reader (-1) diff --git a/Sifflet/UI/Tool.hs b/Sifflet/UI/Tool.hs --- a/Sifflet/UI/Tool.hs +++ b/Sifflet/UI/Tool.hs @@ -47,6 +47,7 @@ import Sifflet.Data.TreeGraph (graphToOrderedTreeFrom) import Sifflet.Data.WGraph import Sifflet.Language.Expr +import Sifflet.Language.Parser import Sifflet.UI.Callback import Sifflet.UI.Canvas import Sifflet.UI.Frame @@ -94,7 +95,7 @@ ToolMove -> makeMoveTool ToolDelete -> makeDeleteTool ToolFunction funcname -> functionTool funcname - ToolLiteral expr -> makeFixedLiteralTool expr + ToolLiteral e -> makeFixedLiteralTool e ToolArg argname -> makeFixedArgTool argname @@ -231,19 +232,31 @@ return canvas makeFixedLiteralTool :: Expr -> Tool -makeFixedLiteralTool expr = - case expr of - ELit literal -> - let node = ENode (NLit literal) EvalUntried - addLitNode vw toolContext _mods x y = - case toolContext of - TCEditFrame frame -> - vcFrameAddNode vw frame node [] x y - _ -> - return vw -- Nothing - in Tool ("Literal: " ++ repr literal) return (toToolOpVW addLitNode) - _ -> - errcats ["makeFixedLiteralTool: non-literal expression", show expr] +makeFixedLiteralTool e = + let enode node = ENode node EvalUntried + addLitNode node vw toolContext _mods x y = + case toolContext of + TCEditFrame frame -> + vcFrameAddNode vw frame (enode node) [] x y + _ -> + return vw -- Nothing + mktool node = + Tool ("Literal: " ++ repr e) + return + (toToolOpVW (addLitNode node)) + in case e of + EBool b -> mktool (NBool b) + EChar c -> mktool (NChar c) + ENumber n -> mktool (NNumber n) + EString s -> mktool (NString s) + EList es -> if exprIsLiteral e + then mktool (NList es) + else errcats ["makeFixedLiteralTool: ", + "non-literal list expression", + show e] + _ -> + errcats ["makeFixedLiteralTool: non-literal or", + "extended expression", show e] makeFixedArgTool :: String -> Tool makeFixedArgTool label = @@ -369,7 +382,7 @@ -- Needs uimgr for action when entry is activated showToolEntry winId "Literal value" Nothing -- completions - stringToLiteral -- parser + parseLiteral -- parser -- activateTool -- action ToolLiteral -- tool type specifier @@ -441,11 +454,11 @@ text <- entryGetText entry ; case parser text of Fail msg -> info msg - Succ value -> + Succ v -> grabRemove entry >> widgetDestroy container >> readIORef uiref >>= - vpuiSetTool (toolType value) winId >>= + vpuiSetTool (toolType v) winId >>= writeIORef uiref } diff --git a/Sifflet/UI/Window.hs b/Sifflet/UI/Window.hs --- a/Sifflet/UI/Window.hs +++ b/Sifflet/UI/Window.hs @@ -13,6 +13,7 @@ , showFunctionPadWindow , newFunctionDialog + , openFilePath , setWSCanvasCallbacks , keyBindingsHelpText ) @@ -434,41 +435,46 @@ mpath <- showDialogFileOpen vpui case mpath of Nothing -> return vpui - Just filePath -> - do - { - loadResult <- loadFile vpui filePath - ; case loadResult of - Fail msg -> - showErrorMessage msg >> return vpui - Succ (vpui', functions) -> - let title = "My Functions" - updatePad rp = - -- Figure out which functions are new, - -- i.e., not already on the pad - let oldNames = concat (rpanelContent rp) - loadedNames = map functionName functions - -- use set difference to avoid duplicates - newNames = loadedNames \\ oldNames - newTools = map functionTool newNames - in do - { - ; newPairs <- - mapM (makeNamedToolButton cbmgr) newTools - ; rp' <- rpanelAddWidgets rp newPairs - ; widgetShowAll (rpanelRoot rp) - ; return rp' - } - in do + Just filePath -> openFilePath cbmgr filePath vpui + +-- | Now that we have a file path, go ahead and open it, +-- loading the function definitions into Sifflet + +openFilePath :: CBMgr -> FilePath -> VPUI -> IO VPUI +openFilePath cbmgr filePath vpui = do + { + loadResult <- loadFile vpui filePath + ; case loadResult of + Fail msg -> + showErrorMessage msg >> return vpui + Succ (vpui', functions) -> + let title = "My Functions" + updatePad rp = + -- Figure out which functions are new, + -- i.e., not already on the pad + let oldNames = concat (rpanelContent rp) + loadedNames = map functionName functions + -- use set difference to avoid duplicates + newNames = loadedNames \\ oldNames + newTools = map functionTool newNames + in do { - vpui'' <- - showFunctionPadWindow cbmgr vpui' >>= - updateFunctionPadIO title updatePad - ; return $ vpui'' {vpuiFilePath = mpath, - vpuiFileEnv = vpuiGlobalEnv vpui' - } + ; newPairs <- + mapM (makeNamedToolButton cbmgr) newTools + ; rp' <- rpanelAddWidgets rp newPairs + ; widgetShowAll (rpanelRoot rp) + ; return rp' } - } + in do + { + vpui'' <- + showFunctionPadWindow cbmgr vpui' >>= + updateFunctionPadIO title updatePad + ; return $ vpui'' {vpuiFilePath = Just filePath, + vpuiFileEnv = vpuiGlobalEnv vpui' + } + } + } showDialogFileOpen :: VPUI -> IO (Maybe FilePath) showDialogFileOpen _vpui = do diff --git a/Sifflet/UI/Workspace.hs b/Sifflet/UI/Workspace.hs --- a/Sifflet/UI/Workspace.hs +++ b/Sifflet/UI/Workspace.hs @@ -11,6 +11,7 @@ , addArgToolButtons , addApplyCloseButtons , defineFunction + , workspaceId , openNode -- Quitting: @@ -326,23 +327,25 @@ ; vpuiUpdateCallFrames vpui'' fname } +workspaceId :: String +workspaceId = "Sifflet Workspace" + -- | In the workspace window, update each frame calling the named function -- to reflect the current function definition vpuiUpdateCallFrames :: VPUI -> String -> IO VPUI vpuiUpdateCallFrames vpui fname = - let winId = "Sifflet Workspace" - in case vpuiTryGetWindow vpui winId of - Nothing -> return vpui - Just w -> do - { - ; let canvas = vpuiWindowGetCanvas w - env = vpuiGlobalEnv vpui - frames = callFrames canvas fname - update canv frame = canvasUpdateCallFrame canv frame fname env - ; canvas' <- foldM update canvas frames - ; let w' = vpuiWindowSetCanvas w canvas' - ; return $ vpuiReplaceWindow vpui winId w' - } + case vpuiTryGetWindow vpui workspaceId of + Nothing -> return vpui + Just w -> do + { + ; let canvas = vpuiWindowGetCanvas w + env = vpuiGlobalEnv vpui + frames = callFrames canvas fname + update canv frame = canvasUpdateCallFrame canv frame fname env + ; canvas' <- foldM update canvas frames + ; let w' = vpuiWindowSetCanvas w canvas' + ; return $ vpuiReplaceWindow vpui workspaceId w' + } -- | In the canvas, update a call frame with the current function -- definition from the environment, returning a new canvas. diff --git a/data/sifflet.py b/data/sifflet.py deleted file mode 100644 --- a/data/sifflet.py +++ /dev/null @@ -1,107 +0,0 @@ -# File: sifflet.py -# Python definitions for built-in Sifflet functions - -# The variable "undefined" (sifflet.undefined) is reserved for Sifflet, -# representing an undefined variable. -# Identifiers containing any of the substrings _QUESTION_, _CHR0_, -# _CHR1_, ... _CHR255_ are reserved for Sifflet. -# For example: "zero_QUESTION_", "zero_CHR33_". - -def add1 (n): - return n + 1 - -def sub1 (n): - return n - 1 - -def eqZero (n): - return (n == 0) - -def gtZero (n): - return (n > 0) - -def ltZero (n): - return (n < 0) - -def null (xs): - return xs.null() - -def head (xs): - return xs.head() - -def tail (xs): - return xs.tail() - -def cons (x, xs): - return Cons(x, xs) - -# The List data type -# These could use some methods to implement operations, -# like __eq__ and __repr__ - -# List delimiters - -ListBegin = "li(" -ListEnd = ")" - -class List: - - pass - -class Null (List): - - def __repr__ (self): return ListBegin + ListEnd - - def __repr2__ (self, _): return ListEnd - - def null(self): return True - - def head(self): error("head: empty list") - - def tail(self): error("tail: empty list") - -class Cons (List): - - def __init__ (self, h, t): - self.__head = h - self.__tail = t - - def __repr__ (self): - return self.__repr2__(ListBegin) - - def __repr2__ (self, prefix): - return prefix + repr(self.__head) + self.__tail.__repr2__(", ") - - def null (self): return False - - def head (self): return self.__head - - def tail (self): return self.__tail - -## Create a List (linked list) from any number of arguments, -## using the same notation as when Lists are converted to string reprs: -def li (*args): return al_to_ll(args) - -# Convert between our List type and Python's built-in list type. -# Axioms: -# I. If alist is a Python list, then ll_to_al(al_to_ll(alist)) == alist -# II. If llist is a List, then al_to_ll(ll_to_al(llist)) == llist - -## al_to_ll: convert Python list to our List type (linked list) -def al_to_ll (alist): - node = Null() - n = len(alist) - for i in range(n - 1, -1, -1): - node = cons(alist[i], node) - return node - - -## ll_to_al: convert our List type to Python list (array list) -def ll_to_al (llist): - alist = [] - while not null(llist): - alist.append(head(llist)) - llist = tail(llist) - return alist - -# Handy -empty = Null() diff --git a/data/sifflet.scm b/data/sifflet.scm deleted file mode 100644 --- a/data/sifflet.scm +++ /dev/null @@ -1,28 +0,0 @@ -;;; Sifflet function library for Scheme -;;; -;;; All symbols beginning with "sifflet-" or "*sifflet-" are -;;; reserved by Sifflet. -;;; -;;; The symbol *sifflet-undefined* is expected NOT to be defined! - -;;; Adding and subtracting 1 - -(define (sifflet-add1 n) (+ n 1)) - -(define (sifflet-sub1 n) (- n 1)) - -;;; Scheme's quotient function is incompatible with Haskell div. -(define (sifflet-div x y) (floor (/ x y))) - -;;; Scheme's / operation typically gives exact results: -;;; should this make any difference? -(define sifflet-/ - (if (exact? (/ 3 2)) - (lambda (x y) (exact->inexact (/ x y))) - /)) - -;;; == and /= belong to the Eq class, which implies general -;;; equality, not limited to numbers. -(define (sifflet-not-equal? x y) (not (= x y))) - - diff --git a/datafiles/sifflet.py b/datafiles/sifflet.py new file mode 100644 --- /dev/null +++ b/datafiles/sifflet.py @@ -0,0 +1,107 @@ +# File: sifflet.py +# Python definitions for built-in Sifflet functions + +# The variable "undefined" (sifflet.undefined) is reserved for Sifflet, +# representing an undefined variable. +# Identifiers containing any of the substrings _QUESTION_, _CHR0_, +# _CHR1_, ... _CHR255_ are reserved for Sifflet. +# For example: "zero_QUESTION_", "zero_CHR33_". + +def add1 (n): + return n + 1 + +def sub1 (n): + return n - 1 + +def eqZero (n): + return (n == 0) + +def gtZero (n): + return (n > 0) + +def ltZero (n): + return (n < 0) + +def null (xs): + return xs.null() + +def head (xs): + return xs.head() + +def tail (xs): + return xs.tail() + +def cons (x, xs): + return Cons(x, xs) + +# The List data type +# These could use some methods to implement operations, +# like __eq__ and __repr__ + +# List delimiters + +ListBegin = "li(" +ListEnd = ")" + +class List: + + pass + +class Null (List): + + def __repr__ (self): return ListBegin + ListEnd + + def __repr2__ (self, _): return ListEnd + + def null(self): return True + + def head(self): error("head: empty list") + + def tail(self): error("tail: empty list") + +class Cons (List): + + def __init__ (self, h, t): + self.__head = h + self.__tail = t + + def __repr__ (self): + return self.__repr2__(ListBegin) + + def __repr2__ (self, prefix): + return prefix + repr(self.__head) + self.__tail.__repr2__(", ") + + def null (self): return False + + def head (self): return self.__head + + def tail (self): return self.__tail + +## Create a List (linked list) from any number of arguments, +## using the same notation as when Lists are converted to string reprs: +def li (*args): return al_to_ll(args) + +# Convert between our List type and Python's built-in list type. +# Axioms: +# I. If alist is a Python list, then ll_to_al(al_to_ll(alist)) == alist +# II. If llist is a List, then al_to_ll(ll_to_al(llist)) == llist + +## al_to_ll: convert Python list to our List type (linked list) +def al_to_ll (alist): + node = Null() + n = len(alist) + for i in range(n - 1, -1, -1): + node = cons(alist[i], node) + return node + + +## ll_to_al: convert our List type to Python list (array list) +def ll_to_al (llist): + alist = [] + while not null(llist): + alist.append(head(llist)) + llist = tail(llist) + return alist + +# Handy +empty = Null() diff --git a/datafiles/sifflet.scm b/datafiles/sifflet.scm new file mode 100644 --- /dev/null +++ b/datafiles/sifflet.scm @@ -0,0 +1,28 @@ +;;; Sifflet function library for Scheme +;;; +;;; All symbols beginning with "sifflet-" or "*sifflet-" are +;;; reserved by Sifflet. +;;; +;;; The symbol *sifflet-undefined* is expected NOT to be defined! + +;;; Adding and subtracting 1 + +(define (sifflet-add1 n) (+ n 1)) + +(define (sifflet-sub1 n) (- n 1)) + +;;; Scheme's quotient function is incompatible with Haskell div. +(define (sifflet-div x y) (floor (/ x y))) + +;;; Scheme's / operation typically gives exact results: +;;; should this make any difference? +(define sifflet-/ + (if (exact? (/ 3 2)) + (lambda (x y) (exact->inexact (/ x y))) + /)) + +;;; == and /= belong to the Eq class, which implies general +;;; equality, not limited to numbers. +(define (sifflet-not-equal? x y) (not (= x y))) + + diff --git a/datafiles/siffml-1.0.dtd b/datafiles/siffml-1.0.dtd new file mode 100644 --- /dev/null +++ b/datafiles/siffml-1.0.dtd @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/sifflet-lib.cabal b/sifflet-lib.cabal --- a/sifflet-lib.cabal +++ b/sifflet-lib.cabal @@ -1,5 +1,5 @@ name: sifflet-lib -version: 1.0 +version: 1.1 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -14,14 +14,14 @@ and without notice. synopsis: Library of modules shared by sifflet and its tests and its exporters. -description: Supporting modules for the Sifflet visual, functional programming - language (Hackage 'sifflet' package). +description: Supporting modules for the Sifflet visual, + functional programming language (Hackage 'sifflet' package). category: Language , Visual Programming tested-with: GHC == 6.12 -data-files: sifflet.scm sifflet.py -data-dir: data +data-files: sifflet.scm sifflet.py siffml-1.0.dtd +data-dir: datafiles extra-tmp-files: extra-source-files: README @@ -31,20 +31,17 @@ build-depends: base >= 4.0 && < 4.3, --- begin GTK stuff, should have same version numbers - cairo == 0.11.0, - glib == 0.11.0, - gtk == 0.11.0, +-- begin GTK stuff, these no longer need to have the same version +-- numbers + cairo == 0.11.*, + glib == 0.11.*, + gtk == 0.11.*, -- end containers >= 0.2 && < 0.4, directory >= 1.0 && < 1.1, filepath >= 1.1 && < 1.2, fgl >= 5.4 && < 5.5, haskell98 >= 1.0.1 && < 1.0.2, --- This (haskell-src) should probably be phased out as I replace --- parts of it with Parsec. --- But no, it is needed for export in Sifflet.Language.ToHaskell. - haskell-src >= 1.0.1 && < 1.0.2, hxt >= 8.3 && < 8.6, mtl >= 1.1 && < 1.2, parsec >= 2.1.0.1 && < 2.3, @@ -57,15 +54,16 @@ includes: gtk-2.0/gtk/gtk.h, gtk-2.0/gdk/gdk.h extra-libraries: gdk-x11-2.0 gtk-x11-2.0 exposed-modules: - Sifflet.Data.Geometry + Data.Number.Sifflet + , Sifflet.Data.Geometry , Sifflet.Data.Functoid - , Sifflet.Data.Number , Sifflet.Data.Tree , Sifflet.Data.TreeGraph , Sifflet.Data.TreeLayout , Sifflet.Data.WGraph , Sifflet.Examples , Sifflet.Foreign.Exporter + , Sifflet.Foreign.Haskell , Sifflet.Foreign.Python , Sifflet.Foreign.ToHaskell , Sifflet.Foreign.ToPython