diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -111,8 +111,8 @@ steps: - name: Setup Haskell's GHC and Cabal as required by current Stackage LTS uses: haskell/actions/setup@v1 - with: # lts-17.9 - ghc-version: '8.10.4' + with: # lts-18.14 + ghc-version: '8.10.7' cabal-version: '3.2' - uses: actions/cache@v2 @@ -131,6 +131,7 @@ runs-on: ubuntu-latest needs: build-and-test steps: + - run: sudo apt-get update - run: sudo apt-get install hugs - name: Check out repository uses: actions/checkout@v2 diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -36,7 +36,7 @@ bench/tiers \ $(EGS) GHCIMPORTDIRS = src:test -GHCFLAGS = -O2 $(shell grep -q "Arch Linux" /etc/lsb-release && echo -dynamic) +GHCFLAGS = -O2 -v0 $(shell grep -q "Arch Linux" /etc/lsb-release && echo -dynamic) HUGSIMPORTDIRS = .:./src:./test:./etc/hugs-backports:/usr/lib/hugs/packages/*:../leancheck/src HUGSFLAGS = -98 -h32M RUNPARAMETERS = diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,18 @@ ===================== +v1.0.10 +------- + +* show function-encoded Ordering case expressions exceptionally + +* show function-encoded Bool case expressions exceptionally + +* add `caseBool` and `caseOrdering` to `Data.Express.Fixtures` + +* minor updates in Makefile and CI scripts + + v1.0.8 ------ diff --git a/express.cabal b/express.cabal --- a/express.cabal +++ b/express.cabal @@ -1,6 +1,6 @@ -- Cabal file for express name: express -version: 1.0.8 +version: 1.0.10 synopsis: Dynamically-typed expressions involving function application and variables. description: Express is a library for manipulating dynamically typed Haskell expressions. @@ -63,7 +63,7 @@ source-repository this type: git location: https://github.com/rudymatela/express - tag: v1.0.8 + tag: v1.0.10 library exposed-modules: Data.Express diff --git a/src/Data/Express/Core.hs b/src/Data/Express/Core.hs --- a/src/Data/Express/Core.hs +++ b/src/Data/Express/Core.hs @@ -471,6 +471,15 @@ showParen (d >= 0) $ showString "if " . showsPrecExpr 0 ep . showString " then " . showsPrecExpr 0 ex . showString " else " . showsPrecExpr 0 ey +showsPrecExpr d (Value "case" _ :$ ep :$ ex :$ ey) | typ ep == boolTy = + showParen (d >= 0) $ showString "case " . showsPrecExpr 0 ep + . showString " of False -> " . showsPrecExpr 0 ex + . showString "; True -> " . showsPrecExpr 0 ey +showsPrecExpr d (Value "case" _ :$ eo :$ ex :$ ey :$ ez) | typ eo == orderingTy = + showParen (d >= 0) $ showString "case " . showsPrecExpr 0 eo + . showString " of LT -> " . showsPrecExpr 0 ex + . showString "; EQ -> " . showsPrecExpr 0 ey + . showString "; GT -> " . showsPrecExpr 0 ez showsPrecExpr d (Value ",.." _ :$ ex :$ ey :$ ez) = showString "[" . showsPrecExpr 0 ex . showString (if dotdot ex && dotdot ey && dotdot ez then "," else ", ") diff --git a/src/Data/Express/Fixtures.hs b/src/Data/Express/Fixtures.hs --- a/src/Data/Express/Fixtures.hs +++ b/src/Data/Express/Fixtures.hs @@ -111,6 +111,8 @@ , (-<-) , compare' , if' + , caseBool + , caseOrdering -- ** Integers , i_, xx, yy, zz, xx' @@ -1472,8 +1474,9 @@ err = error $ "(-<-): unhandled type " ++ show (typ ex) infix 4 -<- --- | A virtual function @if :: Bool -> a -> a -> a@ lifted over the 'Expr' type. --- This is displayed as an if-then-else. +-- | A function @if :: Bool -> a -> a -> a@ lifted over the 'Expr' type +-- that encodes if-then-else functionality. +-- This is properly displayed as an if-then-else. -- -- > > if' pp zero xx -- > (if p then 0 else x) :: Int @@ -1501,6 +1504,78 @@ iff :: Bool -> a -> a -> a iff p x y = if p then x else y type If a = Bool -> a -> a -> a + +-- | A function @case :: Bool -> a -> a -> a@ lifted over the 'Expr' type +-- that encodes case-of-False-True functionality. +-- This is properly displayed as a case-of-False-True expression. +-- +-- > > caseBool pp zero xx +-- > (case p of False -> 0; True -> x) :: Int +-- +-- > > zz -*- caseBool pp xx yy +-- > z * (case p of False -> x; True -> y) :: Int +-- +-- > > caseBool pp false true -||- caseBool qq true false +-- > (caseBool p of False -> False; True -> True) || (caseBool q of False -> True; True -> False) :: Bool +-- +-- > > evl $ caseBool true (val 'f') (val 't') :: Char +-- > 't' +-- +-- By convention, the 'False' case comes before 'True' +-- as @False < True@ and @data Bool = False | True@. +-- +-- When evaluating, this is equivalent to if with arguments reversed. +-- Instead of using this, you are perhaps better of using if encoded as an +-- expression. This is just here to be consistent with 'caseOrdering'. +caseBool :: Expr -> Expr -> Expr -> Expr +caseBool ep ex ey = (:$ ey) . headOr err . mapMaybe ($$ ex) $ map (:$ ep) + [ value "case" (caseB :: CaseB ()) + , value "case" (caseB :: CaseB Int) + , value "case" (caseB :: CaseB Bool) + , value "case" (caseB :: CaseB Char) + , value "case" (caseB :: CaseB [Int]) + , value "case" (caseB :: CaseB [Bool]) + , value "case" (caseB :: CaseB [Char]) + ] + where + err = error $ "caseBool: unhandled type " ++ show (typ ex) + caseB :: Bool -> a -> a -> a + caseB p x y = case p of + False -> x + True -> y +type CaseB a = Bool -> a -> a -> a + +-- | A function @case :: Ordering -> a -> a -> a -> a@ lifted over the 'Expr' type +-- that encodes case-of-LT-EQ-GT functionality. +-- This is properly displayed as a case-of-LT-EQ-GT expression. +-- (cf. 'caseBool') +-- +-- > > caseOrdering (xx `compare'` yy) zero one two +-- > (case compare x y of LT -> 0; EQ -> 1; GT -> 2) :: Int +-- +-- > > evl $ caseOrdering (val EQ) (val 'l') (val 'e') (val 'g') :: Char +-- > 'e' +-- +-- By convention cases are given in 'LT', 'EQ' and 'GT' order +-- as @LT < EQ < GT@ and @data Ordering = LT | EQ | GT@. +caseOrdering :: Expr -> Expr -> Expr -> Expr -> Expr +caseOrdering eo ex ey ez = (:$ ez) . (:$ ey) . headOr err . mapMaybe ($$ ex) $ map (:$ eo) + [ value "case" (caseO :: CaseO ()) + , value "case" (caseO :: CaseO Int) + , value "case" (caseO :: CaseO Bool) + , value "case" (caseO :: CaseO Char) + , value "case" (caseO :: CaseO [Int]) + , value "case" (caseO :: CaseO [Bool]) + , value "case" (caseO :: CaseO [Char]) + ] + where + err = error $ "caseOrdering: unhandled type " ++ show (typ ex) + caseO :: Ordering -> a -> a -> a -> a + caseO o x y z = case o of + LT -> x + EQ -> y + GT -> z +type CaseO a = Ordering -> a -> a -> a -> a -- | Constructs an 'Expr'-encoded 'compare' operation between two 'Expr's. -- diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-17.9 # or ghc-8.10.4 +resolver: lts-18.14 # or ghc-8.10.7 packages: - . diff --git a/test/fixtures.hs b/test/fixtures.hs --- a/test/fixtures.hs +++ b/test/fixtures.hs @@ -185,6 +185,15 @@ , evl (if' false zero one) == (1 :: Int) , evl (if' true two three) == (2 :: Int) + -- caseBool -- + , evl (caseBool false zero one) == (0 :: Int) + , evl (caseBool true two three) == (3 :: Int) + + -- caseOrdering -- + , evl (caseOrdering (val LT) zero one two) == (0 :: Int) + , evl (caseOrdering (val EQ) three four five) == (4 :: Int) + , evl (caseOrdering (val GT) six seven eight) == (8 :: Int) + -- enumFrom and enumFromTo , show (enumFrom' false) == "enumFrom False :: [Bool]" , evl (enumFrom' false) == [False,True] diff --git a/test/show.hs b/test/show.hs --- a/test/show.hs +++ b/test/show.hs @@ -86,11 +86,37 @@ == "(if p then False else True) || (if q then True else False) :: Bool" , show (if' (null' xxs) zero (head' xxs -+- value "sum" (sum :: [Int] -> Int) :$ tail' xxs)) == "(if null xs then 0 else head xs + sum (tail xs)) :: Int" + , show (if' (xx -<- yy) (ff xx) (yy -*- zz)) == "(if x < y then f x else y * z) :: Int" + , show (caseBool pp xx yy) == "(case p of False -> x; True -> y) :: Int" + , show (caseBool false zero one) == "(case False of False -> 0; True -> 1) :: Int" + , show (caseBool true two three) == "(case True of False -> 2; True -> 3) :: Int" + , show (caseBool pp false true) == "(case p of False -> False; True -> True) :: Bool" + , show (not' (caseBool pp false true)) == "not (case p of False -> False; True -> True) :: Bool" + , show (caseBool pp xx yy -*- zz) == "(case p of False -> x; True -> y) * z :: Int" + , show (zz -*- caseBool pp xx yy) == "z * (case p of False -> x; True -> y) :: Int" + , showExpr (if' pp xx yy) == "if p then x else y" , showExpr (if' false zero one) == "if False then 0 else 1" , showExpr (if' true two three) == "if True then 2 else 3" , showExpr (if' pp false true) == "if p then False else True" + , showExpr (if' (xx -<- yy) (ff xx) (yy -*- zz)) == "if x < y then f x else y * z" + + , showExpr (caseBool pp xx yy) == "case p of False -> x; True -> y" + , showExpr (caseBool false zero one) == "case False of False -> 0; True -> 1" + , showExpr (caseBool true two three) == "case True of False -> 2; True -> 3" + , showExpr (caseBool pp false true) == "case p of False -> False; True -> True" + , showExpr (caseBool pp true false) == "case p of False -> True; True -> False" + + , show (caseOrdering (compare' xx yy) xx zz yy) == "(case compare x y of LT -> x; EQ -> z; GT -> y) :: Int" + , show (caseOrdering (val LT) zero one two) == "(case LT of LT -> 0; EQ -> 1; GT -> 2) :: Int" + , show (caseOrdering (val GT) three four five) == "(case GT of LT -> 3; EQ -> 4; GT -> 5) :: Int" + , show (caseOrdering (compare' xx yy) (ff xx) zz (yy -+- zz)) == "(case compare x y of LT -> f x; EQ -> z; GT -> y + z) :: Int" + + , showExpr (caseOrdering (compare' xx yy) xx zz yy) == "case compare x y of LT -> x; EQ -> z; GT -> y" + , showExpr (caseOrdering (val LT) zero one two) == "case LT of LT -> 0; EQ -> 1; GT -> 2" + , showExpr (caseOrdering (val GT) three four five) == "case GT of LT -> 3; EQ -> 4; GT -> 5" + , showExpr (caseOrdering (compare' xx yy) (ff xx) zz (yy -+- zz)) == "case compare x y of LT -> f x; EQ -> z; GT -> y + z" -- showing holes -- , show (hole (undefined :: Int -> Int) :$ one) == "_ 1 :: Int"