Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: sphynx/tapl
base: c3e808e64a
...
head fork: sphynx/tapl
compare: dab5074552
  • 4 commits
  • 5 files changed
  • 0 commit comments
  • 1 contributor
View
2  .gitignore
@@ -3,3 +3,5 @@ misc/
*.o
*.hi
Interpreter
+Tests
+TAGS
View
20 fulluntyped/Makefile
@@ -3,12 +3,24 @@ all: test
clean:
rm -vf *.hi *.o
rm -f Interpreter
+ rm -f Tests
-compile: clean
- ghc Interpreter.hs -main-is Interpreter.main
+compile:
+ ghc -Wall Interpreter.hs -main-is Interpreter.main
-test: compile
+run: compile
./Interpreter
+test: compile
+ ghc -package test-framework -package test-framework-hunit \
+ -threaded Tests.hs -o Tests \
+ -main-is Tests.main
+ ./Tests --maximum-generated-tests=5000 +RTS -N2
+
+# exclude LambdaEncoding from hlinting, since we have lots of
+# intended redundand lambdas there
hlint:
- hlint .
+ find -name '*.hs' -not -name 'LambdaEncoding.hs' | xargs hlint
+
+tags:
+ find -name '*.hs' | xargs hasktags -e
View
9 fulluntyped/Parser.hs
@@ -1,7 +1,8 @@
-module Parser where
+module Parser
+ ( parseExpr
+ ) where
import Control.Applicative hiding ((<|>))
-import Control.Monad
import Text.Parsec
import Text.Parsec.String (Parser)
@@ -61,7 +62,5 @@ expr = foldl1 App <$> many1 atomicExpr
parseExpr :: String -> Term
parseExpr t =
case parse (allOf expr) "" t of
- Left err -> error (show err)
+ Left err -> error $ show err
Right ast -> ast
-
-
View
51 fulluntyped/Pretty.hs
@@ -8,9 +8,6 @@ account three facts:
2. Lambda abstraction body stretches to the right as far as
possible: \x.y z k = \x.(y z k)
-3. Application binds tighter than abstraction. I.e. we need parens
-in the second expression here: (\x.x x) (\x.x x)
-
-}
module Pretty
@@ -20,9 +17,6 @@ module Pretty
import Text.PrettyPrint
import Types
- -- for more convenient testcases
-import Parser hiding (lambda, test)
-
-- pretty printing depth, a nice idea by Jón Fairbairn mentioned in
-- Oleg's interpreter, so we can print even divergent terms.
maxDepth :: Int
@@ -40,10 +34,17 @@ pretty = render . go maxDepth where
go' t1 <+> parens (go' t2)
App t1@(Abs {}) t2@(Abs {}) ->
parens (go' t1) <+> parens (go' t2)
+ App t1@(Var {}) t2@(Abs {}) ->
+ go' t1 <+> parens (go' t2)
+ App t1@(App {}) t2@(Abs {}) ->
+ go' t1 <+> parens (go' t2)
App t1@(Abs {}) t2 ->
parens (go' t1) <+> go' t2
App t1 t2 ->
go' t1 <+> go' t2
+ _ ->
+ -- this is here to please "-Wall"
+ error "should not happen, since it is handled earlier"
where
go' = go (d-1)
@@ -58,41 +59,3 @@ dot = char '.'
ellipsis :: Doc
ellipsis = space <> text "..." <> space
-
-
--- Test suite.
-
--- returns a list of failures: (actual, expected)
-tests :: [(String, String)]
-tests = map (\(r,a,e) -> (a,e)) .
- filter (\(r,_,_) -> not r) .
- map (uncurry check) $
- [ identical "x"
- , identical "x y"
- , identical "x y z"
- , identical "x (y z) t"
- , identical "\\x.x"
- , identical "\\x.\\y.x y"
- , identical "(\\x.x x) (\\x.x x)"
- , identical "(\\x.x x) (\\z.z)"
- , identical "(\\x.x x) t"
- , identical "\\x.\\y.\\z.x y z"
- , identical "\\x.x (y z)"
- , identical "\\x.x (y z) t"
- , identical "(\\x.x) y"
- , identical "(\\x.x y) z"
- , ("(x)", "x")
- , ("(x y)", "x y")
- , ("(((x y)))", "x y")
- , ("(x (y) z)", "x y z")
- , ("((x y) z)", "x y z")
- , ("((x y) z) t", "x y z t")
- , ("(b k) ((x y) z) t", "b k (x y z) t")
- , ("\\x.(x y z)", "\\x.x y z")
- , ("\\x.(x y) z", "\\x.x y z")
- , ("(\\x.x x) (t)", "(\\x.x x) t")
- ]
- where
- identical x = (x, x)
- check inp exp = let act = pretty (parseExpr inp)
- in (exp == act, act, exp)
View
61 fulluntyped/Tests.hs
@@ -0,0 +1,61 @@
+{-
+To run test cases we need test-framework package easily installed from
+Hackage.
+
+More details here:
+http://batterseapower.github.com/test-framework/
+
+To run tests try `make test`.
+
+-}
+
+module Tests where
+
+import Test.Framework (defaultMain, testGroup)
+import Test.Framework.Providers.HUnit (testCase)
+
+import Test.HUnit
+
+import Pretty
+import Parser
+
+main :: IO ()
+main = defaultMain tests
+
+tests =
+ [ testGroup "Pretty printing tests" prettyTests
+ ]
+
+prettyTests = map (uncurry mkTestCase)
+ [ identical "x"
+ , identical "x y"
+ , identical "x y z"
+ , identical "x (y z) t"
+ , identical "\\x.x"
+ , identical "\\x.\\y.x y"
+ , identical "(\\x.x x) (\\x.x x)"
+ , identical "(\\x.x x) (\\z.z)"
+ , identical "(\\x.x x) t"
+ , identical "\\x.\\y.\\z.x y z"
+ , identical "\\x.x (y z)"
+ , identical "\\x.x (y z) t"
+ , identical "(\\x.x) y"
+ , identical "(\\x.x y) z"
+ , identical "x (\\y.y)"
+ , identical "x y (\\y.y)"
+ , ("(x)", "x")
+ , ("(x y)", "x y")
+ , ("(((x y)))", "x y")
+ , ("(x (y) z)", "x y z")
+ , ("((x y) z)", "x y z")
+ , ("((x y) z) t", "x y z t")
+ , ("(b k) ((x y) z) t", "b k (x y z) t")
+ , ("\\x.(x y z)", "\\x.x y z")
+ , ("\\x.(x y) z", "\\x.x y z")
+ , ("(\\x.x x) (t)", "(\\x.x x) t")
+ ]
+ where
+ identical x = (x, x)
+ mkTestCase inp exp =
+ testCase ("pretty-printing " ++ inp) $
+ pretty (parseExpr inp) @?= exp

No commit comments for this range

Something went wrong with that request. Please try again.