summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlanZimmerman <>2015-08-13 08:15:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-08-13 08:15:00 (GMT)
commit27eb128bf44b316ec3f0c6236aeab9f447a03f6f (patch)
treed83f18699803849f69d7c4c6bfd0a58b7c7ee533
parentf2c54d0e93b30a9ab4cb1a15b14b1e4b60ee738e (diff)
version 0.3.1.10.3.1.1
-rw-r--r--ChangeLog3
-rw-r--r--ghc-exactprint.cabal3
-rw-r--r--tests/examples/Deprecation.hs.bad16
-rw-r--r--tests/examples/InfixOperator.hs.bad26
-rw-r--r--tests/examples/MultiLineWarningPragma.hs.bad17
-rw-r--r--tests/examples/UnicodeRules.hs.bad16
-rw-r--r--tests/examples/UnicodeSyntax.hs.bad236
7 files changed, 316 insertions, 1 deletions
diff --git a/ChangeLog b/ChangeLog
index e5ac659..3eb4abb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,6 @@
+2015-08-13 v0.3.1.1
+ * Add missing test files to sdist
+
2015-08-02 v0.3.1
* Mark LHS at the beginning of HsCase and HsIf expressions
diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal
index c18c21a..1f9ab6d 100644
--- a/ghc-exactprint.cabal
+++ b/ghc-exactprint.cabal
@@ -1,5 +1,5 @@
name: ghc-exactprint
-version: 0.3.1
+version: 0.3.1.1
synopsis: ExactPrint for GHC
description: Using the API Annotations available from GHC 7.10.2, this
library provides a means to round trip any code that can
@@ -28,6 +28,7 @@ category: Development
build-type: Simple
extra-source-files: ChangeLog
tests/examples/*.hs
+ tests/examples/*.hs.bad
tests/examples/*.hs.expected
tests/examples/*.hs-boot
cabal-version: >=1.10
diff --git a/tests/examples/Deprecation.hs.bad b/tests/examples/Deprecation.hs.bad
new file mode 100644
index 0000000..28fa7df
--- /dev/null
+++ b/tests/examples/Deprecation.hs.bad
@@ -0,0 +1,16 @@
+
+module Deprecation
+{-# Deprecated ["This is a module \"deprecation\"",
+ "multi-line",
+ "with unicode: Fr\232re" ] #-}
+ ( foo )
+ where
+
+{-# DEPRECATEd foo
+ ["This is a multi-line",
+ "deprecation message",
+ "for foo"] #-}
+foo :: Int
+foo = 4
+
+{-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}
diff --git a/tests/examples/InfixOperator.hs.bad b/tests/examples/InfixOperator.hs.bad
new file mode 100644
index 0000000..830ca44
--- /dev/null
+++ b/tests/examples/InfixOperator.hs.bad
@@ -0,0 +1,26 @@
+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+json_ :: Parser Value -> Parser Value -> Parser Value
+json_ obj ary = do
+ w <- skipSpace *> A.satisfy (\w -> w == 123 || w == 91)
+ if w == 123
+ then obj
+ else ary
+{-# INLINE json_ #-}
+
diff --git a/tests/examples/MultiLineWarningPragma.hs.bad b/tests/examples/MultiLineWarningPragma.hs.bad
new file mode 100644
index 0000000..01904f4
--- /dev/null
+++ b/tests/examples/MultiLineWarningPragma.hs.bad
@@ -0,0 +1,17 @@
+
+{-# WARNING Logic
+ , mkSolver
+ , mkSimpleSolver
+ , mkSolverForLogic
+ , solverSetParams
+ , solverPush
+ , solverPop
+ , solverReset
+ , solverGetNumScopes
+ , solverAssertCnstr
+ , solverAssertAndTrack
+ , solverCheck
+ , solverCheckAndGetModel
+ , solverGetReasonUnknown
+ "New Z3 API support is still incomplete and fragile: you may experience segmentation faults!"
+ #-}
diff --git a/tests/examples/UnicodeRules.hs.bad b/tests/examples/UnicodeRules.hs.bad
new file mode 100644
index 0000000..883d40d
--- /dev/null
+++ b/tests/examples/UnicodeRules.hs.bad
@@ -0,0 +1,16 @@
+{-# LANGUAGE
+ BangPatterns
+ , FlexibleContexts
+ , FlexibleInstances
+ , ScopedTypeVariables
+ , UnboxedTuples
+ , UndecidableInstances
+ , UnicodeSyntax
+ #-}
+
+strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool
+{-# RULES "head \8594 strictHead" [1]
+ ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d).
+ head v = strictHead v #-}
+{-# INLINE strictHead #-}
+strictHead (Bitstream _ v) = head (SV.head v)
diff --git a/tests/examples/UnicodeSyntax.hs.bad b/tests/examples/UnicodeSyntax.hs.bad
new file mode 100644
index 0000000..af3ce2e
--- /dev/null
+++ b/tests/examples/UnicodeSyntax.hs.bad
@@ -0,0 +1,236 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UnicodeSyntax #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE Arrows #-}
+
+module Tutorial where
+
+-- import Abt.Class
+-- import Abt.Types
+-- import Abt.Concrete.LocallyNameless
+
+import Control.Applicative
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Except
+-- import Data.Vinyl
+import Prelude hiding (pi)
+
+-- | We'll start off with a monad in which to manipulate ABTs; we'll need some
+-- state for fresh variable generation.
+--
+newtype M α
+ = M
+ { _M ∷ State Int α
+ } deriving (Functor, Applicative, Monad)
+
+-- | We'll run an ABT computation by starting the variable counter at @0@.
+--
+runM ∷ M α → α
+runM (M m) = evalState m 0
+
+-- | Check out the source to see fresh variable generation.
+--
+instance MonadVar Var M where
+ fresh = M $ do
+ n ← get
+ let n' = n + 1
+ put n'
+ return $ Var Nothing n'
+
+ named a = do
+ v ← fresh
+ return $ v { _varName = Just a }
+
+-- | Next, we'll define the operators for a tiny lambda calculus as a datatype
+-- indexed by arities.
+--
+data Lang ns where
+ LAM ∷ Lang '[S Z]
+ APP ∷ Lang '[Z, Z]
+ PI ∷ Lang '[Z, S Z]
+ UNIT ∷ Lang '[]
+ AX ∷ Lang '[]
+
+instance Show1 Lang where
+ show1 = \case
+ LAM → "lam"
+ APP → "ap"
+ PI → "pi"
+ UNIT → "unit"
+ AX → "<>"
+
+instance HEq1 Lang where
+ heq1 LAM LAM = Just Refl
+ heq1 APP APP = Just Refl
+ heq1 PI PI = Just Refl
+ heq1 UNIT UNIT = Just Refl
+ heq1 AX AX = Just Refl
+ heq1 _ _ = Nothing
+
+lam ∷ Tm Lang (S Z) → Tm0 Lang
+lam e = LAM $$ e :& RNil
+
+app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang
+app m n = APP $$ m :& n :& RNil
+
+ax ∷ Tm0 Lang
+ax = AX $$ RNil
+
+unit ∷ Tm0 Lang
+unit = UNIT $$ RNil
+
+pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang
+pi α xβ = PI $$ α :& xβ :& RNil
+
+-- | A monad transformer for small step operational semantics.
+--
+newtype StepT m α
+ = StepT
+ { runStepT ∷ MaybeT m α
+ } deriving (Monad, Functor, Applicative, Alternative)
+
+-- | To indicate that a term is in normal form.
+--
+stepsExhausted
+ ∷ Applicative m
+ ⇒ StepT m α
+stepsExhausted = StepT . MaybeT $ pure Nothing
+
+instance MonadVar Var m ⇒ MonadVar Var (StepT m) where
+ fresh = StepT . MaybeT $ Just <$> fresh
+ named str = StepT . MaybeT $ Just <$> named str
+
+-- | A single evaluation step.
+--
+step
+ ∷ Tm0 Lang
+ → StepT M (Tm0 Lang)
+step tm =
+ out tm >>= \case
+ APP :$ m :& n :& RNil →
+ out m >>= \case
+ LAM :$ xe :& RNil → xe // n
+ _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n
+ PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ
+ _ → stepsExhausted
+
+-- | The reflexive-transitive closure of a small-step operational semantics.
+--
+star
+ ∷ Monad m
+ ⇒ (α → StepT m α)
+ → (α → m α)
+star f a =
+ runMaybeT (runStepT $ f a) >>=
+ return a `maybe` star f
+
+-- | Evaluate a term to normal form
+--
+eval ∷ Tm0 Lang → Tm0 Lang
+eval = runM . star step
+
+newtype JudgeT m α
+ = JudgeT
+ { runJudgeT ∷ ExceptT String m α
+ } deriving (Monad, Functor, Applicative, Alternative)
+
+instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where
+ fresh = JudgeT . ExceptT $ Right <$> fresh
+ named str = JudgeT . ExceptT $ Right <$> named str
+
+type Ctx = [(Var, Tm0 Lang)]
+
+raise ∷ Monad m ⇒ String → JudgeT m α
+raise = JudgeT . ExceptT . return . Left
+
+checkTy
+ ∷ Ctx
+ → Tm0 Lang
+ → Tm0 Lang
+ → JudgeT M ()
+checkTy g tm ty = do
+ let ntm = eval tm
+ nty = eval ty
+ (,) <$> out ntm <*> out nty >>= \case
+ (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do
+ z ← fresh
+ ez ← xe // var z
+ βz ← yβ // var z
+ checkTy ((z,α):g) ez βz
+ (AX :$ RNil, UNIT :$ RNil) → return ()
+ _ → do
+ ty' ← inferTy g tm
+ if ty' === nty
+ then return ()
+ else raise "Type error"
+
+inferTy
+ ∷ Ctx
+ → Tm0 Lang
+ → JudgeT M (Tm0 Lang)
+inferTy g tm = do
+ out (eval tm) >>= \case
+ V v | Just (eval → ty) ← lookup v g → return ty
+ | otherwise → raise "Ill-scoped variable"
+ APP :$ m :& n :& RNil → do
+ inferTy g m >>= out >>= \case
+ PI :$ α :& xβ :& RNil → do
+ checkTy g n α
+ eval <$> xβ // n
+ _ → raise "Expected pi type for lambda abstraction"
+ _ → raise "Only infer neutral terms"
+
+-- | @λx.x@
+--
+identityTm ∷ M (Tm0 Lang)
+identityTm = do
+ x ← fresh
+ return $ lam (x \\ var x)
+
+-- | @(λx.x)(λx.x)@
+--
+appTm ∷ M (Tm0 Lang)
+appTm = do
+ tm ← identityTm
+ return $ app tm tm
+
+-- | A demonstration of evaluating (and pretty-printing). Output:
+--
+-- @
+-- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4]
+-- @
+--
+main ∷ IO ()
+main = do
+ -- Try out the type checker
+ either fail print . runM . runExceptT . runJudgeT $ do
+ x ← fresh
+ checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit))
+
+ print . runM $ do
+ mm ← appTm
+ mmStr ← toString mm
+ mmStr' ← toString $ eval mm
+ return $ mmStr ++ " ~>* " ++ mmStr'
+
+doMap ∷ FilePath → IOSArrow XmlTree TiledMap
+doMap mapPath = proc m → do
+ mapWidth ← getAttrR "width" ⤙ m
+ returnA -< baz
+
+-- ^ An opaque ESD handle for recording data from the soundcard via ESD.
+data Recorder fr ch (r ∷ * → *)
+ = Recorder {
+ reRate ∷ !Int
+ , reHandle ∷ !Handle
+ , reCloseH ∷ !(FinalizerHandle r)
+ }
+