Permalink
Browse files

enabled doctesting

  • Loading branch information...
ekmett committed Sep 13, 2012
1 parent bbe306f commit 24ae1f9548f4a05f14ceadaee32ea146bf88c34a
Showing with 86 additions and 36 deletions.
  1. +17 −3 bound.cabal
  2. +21 −21 examples/Deriving.hs
  3. +12 −10 examples/Overkill.hs
  4. +2 −2 examples/Simple.hs
  5. +5 −0 src/Bound/Term.hs
  6. +29 −0 tests/doctests.hs
View
@@ -123,10 +123,24 @@ library
test-suite Simple
build-depends:
- base >= 4 && < 5,
- prelude-extras >= 0.2 && < 0.3,
- transformers >= 0.2 && < 0.4,
+ base,
+ prelude-extras,
+ transformers,
bound
type: exitcode-stdio-1.0
hs-source-dirs: examples
main-is: Simple.hs
+
+-- Verify the results of the examples
+test-suite doctests
+ type: exitcode-stdio-1.0
+ main-is: doctests.hs
+ build-depends:
+ base,
+ directory >= 1.0 && < 1.3,
+ doctest >= 0.9 && <= 0.10,
+ filepath
+ ghc-options: -Wall -threaded
+ if impl(ghc<7.6.1)
+ ghc-options: -Werror
+ hs-source-dirs: tests
View
@@ -1,5 +1,5 @@
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
-module Exp where
+module Deriving where
import Data.List
import Data.Foldable
@@ -61,6 +61,9 @@ instance Bound Alt where
data P a = P { pattern :: [a] -> Pat Exp a, bindings :: [a] }
+-- |
+-- >>> lam (varp "x") (V "x")
+-- Lam 1 VarP (Scope (V (B 0)))
varp :: a -> P a
varp a = P (const VarP) [a]
@@ -70,6 +73,9 @@ wildp = P (const WildP) []
asp :: a -> P a -> P a
asp a (P p as) = P (\bs -> AsP (p (a:bs))) (a:as)
+-- |
+-- >>> lam (conp "Hello" [varp "x", wildp]) (V "y")
+-- Lam 1 (ConP "Hello" [VarP,WildP]) (Scope (V (F (V "y"))))
conp :: String -> [P a] -> P a
conp g ps = P (ConP g . go ps) (ps >>= bindings)
where
@@ -81,6 +87,15 @@ viewp :: Eq a => Exp a -> P a -> P a
viewp t (P p as) = P (\bs -> ViewP (abstract (`elemIndex` bs) t) (p bs)) as
-- | smart lam constructor
+--
+-- >>> let_ [("x",V "y"),("y",V "x" :@ V "y")] $ lam (varp "z") (V "z" :@ V "y")
+-- Let 2 [Scope (V (B 1)),Scope (V (B 0) :@ V (B 1))] (Scope (Lam 1 VarP (Scope (V (B 0) :@ V (F (V (B 1)))))))
+--
+-- >>> lam (conp "F" [varp "x", viewp (V "x") $ varp "y"]) (V "y")
+-- Lam 2 (ConP "F" [VarP,ViewP (Scope (V (B 0))) VarP]) (Scope (V (B 1)))
+--
+-- >>> lam (conp "F" [varp "x", viewp (V "y") $ varp "y"]) (V "y")
+-- Lam 2 (ConP "F" [VarP,ViewP (Scope (V (F (V "y")))) VarP]) (Scope (V (B 1)))
lam :: Eq a => P a -> Exp a -> Exp a
lam (P p as) t = Lam (length as) (p []) (abstract (`elemIndex` as) t)
@@ -91,26 +106,11 @@ let_ bs b = Let (length bs) (map (abstr . snd) bs) (abstr b)
abstr = abstract (`elemIndex` vs)
-- | smart alt constructor
-alt :: Eq a => P a -> Exp a -> Alt Exp a
-alt (P p as) t = Alt (length as) (p []) (abstract (`elemIndex` as) t)
-
--- >>> let_ [("x",V "y"),("y",V "x" :@ V "y")] $ lam (varp "z") (V "z" :@ V "y")
--- Let 2 [Scope (V (B 1)),Scope (V (B 0) :@ V (B 1))] (Scope (Lam 1 VarP (Scope (V (B 0) :@ V (F (V (B 1)))))))
-
--- >>> lam (varp "x") (V "x")
--- Lam 1 VarP (Scope (V (B 0)))
-
--- >>> lam (conp "Hello" [varp "x", wildp]) (V "y")
--- Lam 1 (ConP "Hello" [VarP,WildP]) (Scope (V (F (V "y"))))
-
+--
-- >>> lam (varp "x") $ Case (V "x") [alt (conp "Hello" [varp "z",wildp]) (V "x"), alt (varp "y") (V "y")]
-- Lam 1 VarP (Scope (Case (V (B 0)) [Alt 1 (ConP "Hello" [VarP,WildP]) (Scope (V (F (V (B 0))))),Alt 1 VarP (Scope (V (B 0)))]))
+alt :: Eq a => P a -> Exp a -> Alt Exp a
+alt (P p as) t = Alt (length as) (p []) (abstract (`elemIndex` as) t)
--- view patterns can reference name from earlier in the same scope
--- >>> lam (conp "F" [varp "x", viewp (V "x") $ varp "y"]) (V "y")
--- Lam 2 (ConP "F" [VarP,ViewP (Scope (V (B 0))) VarP]) (Scope (V (B 1)))
-
--- but like in ghc, they refuse to allow references to subsequent bindings in the scope
--- >>> lam (conp "F" [varp "x", viewp (V "y") $ varp "y"]) (V "y")
--- Lam 2 (ConP "F" [VarP,ViewP (Scope (V (F (V "y")))) VarP]) (Scope (V (B 1)))
-
+main :: IO ()
+main = return ()
View
@@ -9,7 +9,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeOperators #-}
-module Exp where
+module Overkill where
import Data.Vector as Vector hiding ((++), map)
import Data.List as List
@@ -189,8 +189,6 @@ instance Bound (Pat b) where
ViewP e p >>>= f = ViewP (e >>= f) (p >>>= f)
-- ** Pats
-
-
eqPats :: (Eq1 f, Eq a) => Pats bs f a -> Pats bs' f a -> Bool
eqPats NilP NilP = True
eqPats (p :> ps) (q :> qs) = eqPat p q && eqPats ps qs
@@ -221,9 +219,7 @@ instance Bound (Pats bs) where
NilP >>>= _ = NilP
(p :> ps) >>>= f = (p >>>= f) :> (ps >>>= f)
-
-- ** Path into Pats
-
eqMPath :: MPath is -> MPath js -> Bool
eqMPath (H m) (H n) = eqPath m n
eqMPath (T p) (T q) = eqMPath p q
@@ -244,8 +240,6 @@ instance Show (MPath is) where
-- instance Read (MPath is)
-- ** Path into Pat
-
-
eqPath :: Path i -> Path j -> Bool
eqPath V V = True
eqPath L L = True
@@ -282,6 +276,14 @@ instance Show (Path i) where
showsPrec d (R m) = showParen (d > 10) $ showString "R " . showsPrec 11 m
showsPrec d (C p) = showParen (d > 10) $ showString "C " . showsPrec 11 p
--- ghci> let_ [("x",Var "y"),("y",Var "x" :@ Var "y")] $ lam (varp "z") (Var "z" :@ Var "y")
--- ghci> lam (varp "x") (Var "x")
--- ghci> lam (conp "Hello" [varp "x", wildp])) (Var "y")
+-- |
+-- >>> let_ [("x",Var "y"),("y",Var "x" :@ Var "y")] $ lam (varp "z") (Var "z" :@ Var "y")
+-- Let (fromList [Scope (Var (B 1)),Scope (Var (B 0) :@ Var (B 1))]) (Scope (Lam VarP (Scope (Var (B V) :@ Var (F (Var (B 1)))))))
+--
+-- >>> lam (varp "x") (Var "x")
+-- Lam VarP (Scope (Var (B V)))
+--
+-- >>> lam (conp "Hello" [varp "x", wildp]) (Var "y")
+-- Lam (ConP "Hello" (VarP :> WildP :> NilP)) (Scope (Var (F (Var "y"))))
+main :: IO ()
+main = return ()
View
@@ -27,7 +27,7 @@ data Exp a
-- | A smart constructor for Lam
--
-- >>> lam "y" (lam "x" (V "x" :@ V "y"))
--- Lam (Lam (V (B ()) :@ V (F (V (B ())))))
+-- Lam (Scope (Lam (Scope (V (B ()) :@ V (F (V (B ())))))))
lam :: Eq a => a -> Exp a -> Exp a
lam v b = Lam (abstract1 v b)
@@ -95,7 +95,7 @@ infixr 0 !
--
-- Modified to use recursive let, because we can.
--
--- >>> nf cooked == lam "false" (lam "true" (V"false"))
+-- >>> nf cooked == true
-- True
true :: Exp String
View
@@ -11,6 +11,7 @@
----------------------------------------------------------------------------
module Bound.Term
( substitute
+ , substituteVar
, isClosed
, closed
) where
@@ -24,6 +25,10 @@ substitute :: (Monad f, Eq a) => a -> f a -> f a -> f a
substitute a p w = w >>= \b -> if a == b then p else return b
{-# INLINE substitute #-}
+substituteVar :: (Functor f, Eq a) => a -> a -> f a -> f a
+substituteVar a p = fmap (\b -> if a == b then p else b)
+{-# INLINE substituteVar #-}
+
-- | If a term has no free variables, you can freely change the type of
-- free variables it is parameterized on.
closed :: Traversable f => f a -> Maybe (f b)
View
@@ -0,0 +1,29 @@
+module Main where
+
+import Test.DocTest
+import System.Directory
+import System.FilePath
+import Control.Applicative
+import Control.Monad
+import Data.List
+
+main :: IO ()
+main = getSources >>= \sources -> doctest $
+ "-iexamples"
+ : "-isrc"
+ : "-idist/build/autogen"
+ : "-optP-include"
+ : "-optPdist/build/autogen/cabal_macros.h"
+ : sources
+
+getSources :: IO [FilePath]
+getSources = filter (isSuffixOf ".hs") <$> go "examples"
+ where
+ go dir = do
+ (dirs, files) <- getFilesAndDirectories dir
+ (files ++) . concat <$> mapM go dirs
+
+getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])
+getFilesAndDirectories dir = do
+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir
+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c

0 comments on commit 24ae1f9

Please sign in to comment.