sifflet-lib 1.0 → 1.1
raw patch · 24 files changed
+1664/−1560 lines, 24 filesdep −haskell-srcdep ~cairodep ~glibdep ~gtk
Dependencies removed: haskell-src
Dependency ranges changed: cairo, glib, gtk
Files
- Data/Number/Sifflet.hs +271/−0
- Sifflet/Data/Number.hs +0/−288
- Sifflet/Examples.hs +10/−23
- Sifflet/Foreign/Exporter.hs +185/−2
- Sifflet/Foreign/Haskell.hs +155/−0
- Sifflet/Foreign/Python.hs +98/−339
- Sifflet/Foreign/ToHaskell.hs +74/−290
- Sifflet/Foreign/ToPython.hs +66/−61
- Sifflet/Foreign/ToScheme.hs +12/−5
- Sifflet/Language/Expr.hs +282/−214
- Sifflet/Language/Parser.hs +77/−56
- Sifflet/Language/SiffML.hs +122/−58
- Sifflet/Text/Pretty.hs +9/−1
- Sifflet/Text/Repr.hs +4/−1
- Sifflet/UI/Canvas.hs +3/−9
- Sifflet/UI/Tool.hs +30/−17
- Sifflet/UI/Window.hs +39/−33
- Sifflet/UI/Workspace.hs +16/−13
- data/sifflet.py +0/−107
- data/sifflet.scm +0/−28
- datafiles/sifflet.py +107/−0
- datafiles/sifflet.scm +28/−0
- datafiles/siffml-1.0.dtd +63/−0
- sifflet-lib.cabal +13/−15
+ Data/Number/Sifflet.hs view
@@ -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!
− Sifflet/Data/Number.hs
@@ -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
Sifflet/Examples.hs view
@@ -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"
Sifflet/Foreign/Exporter.hs view
@@ -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'
+ Sifflet/Foreign/Haskell.hs view
@@ -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+ ])+
Sifflet/Foreign/Python.hs view
@@ -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+ ])
Sifflet/Foreign/ToHaskell.hs view
@@ -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 = "<unknown", srcLine = 1, srcColumn = 1}---- | A Haskell module.-hsModule :: String -> [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
Sifflet/Foreign/ToPython.hs view
@@ -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 =
Sifflet/Foreign/ToScheme.hs view
@@ -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! " ++
Sifflet/Language/Expr.hs view
@@ -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,
Sifflet/Language/Parser.hs view
@@ -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
Sifflet/Language/SiffML.hs view
@@ -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 <literal><float>2.5</float></literal>- -- to <float>2.5</float>, 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]
Sifflet/Text/Pretty.hs view
@@ -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
Sifflet/Text/Repr.hs view
@@ -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.
Sifflet/UI/Canvas.hs view
@@ -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)
Sifflet/UI/Tool.hs view
@@ -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 }
Sifflet/UI/Window.hs view
@@ -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
Sifflet/UI/Workspace.hs view
@@ -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.
− data/sifflet.py
@@ -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()
− data/sifflet.scm
@@ -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)))--
+ datafiles/sifflet.py view
@@ -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()
+ datafiles/sifflet.scm view
@@ -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)))++
+ datafiles/siffml-1.0.dtd view
@@ -0,0 +1,63 @@+<!-- siffml-1.0 DTD.+ root element is "functions",+ but how is that made clear?+-->++<!-- "parameter entities" for use within the DTD -->++<!-- variants of VpType -->+<!ENTITY % sifflet-type + "(string-type|char-type|num-type|bool-type|list-type|type-variable)">++<!-- Variants of Expr.+ Expr also has a EList constructor, but this is not used+ in SiffML -->+<!ENTITY % sifflet-expr "(undefined|symbol|literal|if|call)">++<!-- Variants of Value -->+<!ENTITY % sifflet-value + "(True|False|char|string|int|float|list|function)">++<!-- elements -->++<!ELEMENT functions (compound-function*)>++<!ELEMENT compound-function (name, return-type, arg-types,+ arg-names, body)>++<!ELEMENT name (#PCDATA)>+<!ELEMENT return-type %sifflet-type;> +<!ELEMENT arg-types ((%sifflet-type;)*)>+<!ELEMENT arg-names (name*)>++<!ELEMENT body (%sifflet-expr;)>++<!-- type elements -->+<!ELEMENT string-type EMPTY>+<!ELEMENT char-type EMPTY>+<!ELEMENT num-type EMPTY>+<!ELEMENT bool-type EMPTY>+<!ELEMENT list-type (%sifflet-type;)>+<!ELEMENT type-variable (#PCDATA)>++<!-- expr elements -->++<!ELEMENT undefined EMPTY>+<!ELEMENT symbol (#PCDATA)>+<!ELEMENT literal (%sifflet-value;)>+<!ELEMENT if ((%sifflet-expr;), (%sifflet-expr;), (%sifflet-expr;))>+<!-- a "list" element as an expr is probably a mistake -->+<!-- <!ELEMENT list ((%sifflet-expr;)*)> -->+<!ELEMENT call (symbol, (%sifflet-expr;)*)>++<!-- value elements -->++<!ELEMENT True EMPTY>+<!ELEMENT False EMPTY>+<!ELEMENT char (#PCDATA)>+<!ELEMENT string (#PCDATA)>+<!ELEMENT int (#PCDATA)>+<!ELEMENT float (#PCDATA)>+<!-- a "list" element represents a list value, not a list expr -->+<!ELEMENT list ((%sifflet-value;)*)>+<!ELEMENT function (compound-function)> <!-- shouldn't happen though -->
sifflet-lib.cabal view
@@ -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