haskell-generate (empty) → 0.1

raw patch · 13 files changed

+661/−0 lines, 13 filesdep +basedep +containersdep +directorybuild-type:Customsetup-changed

Dependencies added: base, containers, directory, doctest, filepath, haskell-src-exts, template-haskell, transformers

Files

• .ghci +1/−0
• .gitignore +15/−0
• .travis.yml +23/−0
• .vim.custom +31/−0
• LICENSE +30/−0
• README.md +6/−0
• Setup.hs +69/−0
• haskell-generate.cabal +56/−0
• src/Language/Haskell/Generate.hs +6/−0
• src/Language/Haskell/Generate/Base.hs +204/−0
• src/Language/Haskell/Generate/PreludeDef.hs +94/−0
• src/Language/Haskell/Generate/TH.hs +52/−0
• tests/doctests.hsc +74/−0

@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h

@@ -0,0 +1,15 @@+dist+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox+cabal.sandbox.config

@@ -0,0 +1,23 @@+env:+ - GHCVER=7.4.2 CABALVER=1.16+ - GHCVER=7.6.3 CABALVER=1.18+ - GHCVER=head CABALVER=1.18 ++before_install:+ - sudo add-apt-repository -y ppa:hvr/ghc+ - sudo apt-get update+ - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER happy hlint+ - export PATH=/opt/ghc/$GHCVER/bin:$PATH++install:+ - cabal-$CABALVER update+ - cabal-$CABALVER install --only-dependencies --enable-tests --enable-benchmarks -j++script:+ - travis/script.sh+ - hlint src++matrix:+  allow_failures:+   - env: GHCVER=head CABALVER=1.18+  fast_finish: true

@@ -0,0 +1,31 @@+" Add the following to your .vimrc to automatically load this on startup++" if filereadable(".vim.custom")+"     so .vim.custom+" endif++function StripTrailingWhitespace()+  let myline=line(".")+  let mycolumn = col(".")+  silent %s/  *$//+  call cursor(myline, mycolumn)+endfunction++" enable syntax highlighting+syntax on++" search for the tags file anywhere between here and /+set tags=TAGS;/++" highlight tabs and trailing spaces+set listchars=tab:‗‗,trail:‗+set list++" f2 runs hasktags+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" strip trailing whitespace before saving+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"

@@ -0,0 +1,30 @@+Copyright 2013 Benno Fünfstück++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,6 @@+haskell-generate+====================++[![Build Status](https://secure.travis-ci.org/bennofs/haskell-generate.png?branch=master)](http://travis-ci.org/bennofs/haskell-generate)++

@@ -0,0 +1,69 @@+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.IORef+import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..), hsSourceDirs, libBuildInfo, buildInfo)+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, withExeLBI, ComponentLocalBuildInfo(), LocalBuildInfo(), componentPackageDeps )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag, buildDistPref, defaultDistPref, fromFlagOrDefault )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Verbosity ( Verbosity )+import System.Directory ( canonicalizePath )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi flags+     buildHook simpleUserHooks pkg lbi hooks flags+  }++--  Very ad-hoc implementation of difference lists+singletonDL :: a -> [a] -> [a]+singletonDL = (:)++emptyDL :: [a] -> [a]+emptyDL = id++appendDL :: ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]+appendDL x y = x . y++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> BuildFlags -> IO ()+generateBuildModule verbosity pkg lbi flags = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withTestLBI pkg lbi $ \suite suitelbi -> do+    srcDirs <- mapM canonicalizePath $ hsSourceDirs $ testBuildInfo suite+    distDir <- canonicalizePath $ fromFlagOrDefault defaultDistPref $ buildDistPref flags++    depsVar <- newIORef emptyDL+    withLibLBI pkg lbi $ \lib liblbi ->+      modifyIORef depsVar $ appendDL . singletonDL $ depsEntry (libBuildInfo lib) liblbi suitelbi+    withExeLBI pkg lbi $ \exe exelbi ->+      modifyIORef depsVar $ appendDL . singletonDL $ depsEntry (buildInfo exe) exelbi suitelbi+    deps <- fmap ($ []) $ readIORef depsVar++    rewriteFile (map fixchar $ dir </> "Build_" ++ testName suite ++ ".hs") $ unlines +      [ "module Build_" ++ map fixchar (testName suite) ++ " where"+      , "getDistDir :: FilePath"+      , "getDistDir = " ++ show distDir+      , "getSrcDirs :: [FilePath]"+      , "getSrcDirs = " ++ show srcDirs+      , "deps :: [([FilePath], [String])]"+      , "deps = " ++ show deps+      ]++  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)+    depsEntry targetbi targetlbi suitelbi = (hsSourceDirs targetbi, formatdeps $ testDeps targetlbi suitelbi)+    fixchar '-' = '_'+    fixchar c = c++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys

@@ -0,0 +1,56 @@+name:          haskell-generate+version:       0.1+license:       BSD3+category:      Code Generation, Language+cabal-version: >= 1.10+license-file:  LICENSE+author:        Benno Fünfstück+maintainer:    Benno Fünfstück <benno.fuenfstueck@gmail.com>+stability:     experimental+homepage:      http://github.com/bennofs/haskell-generate/+bug-reports:   http://github.com/bennofs/haskell-generate/issues+copyright:     Copyright (C) 2013 Benno Fünfstück+synopsis:      haskell-generate+description:   haskell-generate+build-type:    Custom++extra-source-files:+  .ghci+  .gitignore+  .travis.yml+  .vim.custom+  README.md++source-repository head+  type: git+  location: https://github.com/bennofs/haskell-generate.git++library+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall+  build-depends:+      base >= 4.4 && < 5+    , transformers+    , haskell-src-exts+    , containers+    , template-haskell+  exposed-modules:+      Language.Haskell.Generate+      Language.Haskell.Generate.Base+      Language.Haskell.Generate.TH+      Language.Haskell.Generate.PreludeDef++test-suite doctests+  type:    exitcode-stdio-1.0+  main-is: doctests.hs+  default-language: Haskell2010+  build-depends:+      base+    , directory >= 1.0+    , doctest >= 0.9.1+    , filepath+  ghc-options: -Wall -threaded+  if impl(ghc<7.6.1)+    ghc-options: -Werror+  hs-source-dirs: tests

@@ -0,0 +1,6 @@+module Language.Haskell.Generate+  ( module X+  ) where++import Language.Haskell.Generate.Base as X+import Language.Haskell.Generate.PreludeDef as X

@@ -0,0 +1,204 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Language.Haskell.Generate.Base +  ( ExpM(..), ExpG, ExpType+  , runExpM, newName+  , useValue, useCon, useVar+  , caseE+  , applyE, applyE2, applyE3, applyE4, applyE5, applyE6+  , (<>$)+  , GenExp(..)+  , ModuleM(..)+  , ModuleG+  , FunRef(..)+  , Name(..)+  , exportFun+  , addDecl+  , runModuleM+  , generateModule+  )+  where++import           Control.Applicative+import           Control.Monad+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.State+import           Control.Monad.Trans.Writer+import qualified Data.Set as S+import           Language.Haskell.Exts.Pretty+import           Language.Haskell.Exts.SrcLoc+import           Language.Haskell.Exts.Syntax++--------------------------------------------------------------------------------+-- Generate expressions++-- | A ExpM is a monad used to track the imports that are needed for a given expression. Usually, you don't have to use+-- this type directly, but use combinators to combine several ExpM into bigger expressions. The t type parameter tracks+-- the type of the expression, so you don't accidently build expression that don't type check.+newtype ExpM t a = ExpM { unExpM :: StateT Integer (Writer (S.Set ModuleName)) a } deriving (Functor, Applicative, Monad)++-- | The ExpG type is a ExpM computation that returns an expression. Usually, this is the end result of a function generating +-- a haskell expression+type ExpG t = ExpM t Exp++-- | Evaluate a ExpM action, returning the needed modules and the value.+runExpM :: ExpM t a -> (a, S.Set ModuleName)+runExpM (ExpM expt) = runWriter $ evalStateT expt 0++unsafeCoerceE :: ExpM t a -> ExpM t' a+unsafeCoerceE (ExpM x) = ExpM x++-- | Generate a case expression.+caseE :: ExpG x -> [(Pat, ExpG t)] -> ExpG t+caseE v alt = do+  v' <- unsafeCoerceE v+  alt' <- mapM (\(p,a) -> fmap (\a' -> Alt noLoc p (UnGuardedAlt a') (BDecls [])) a) alt+  return $ Case v' alt'++-- | Import a function from a module. This function is polymorphic in the type of the resulting expression, +-- you should probably only use this function to define type-restricted specializations. +--+-- Example:+--+-- > addInt :: ExpG (Int -> Int -> Int) -- Here we restricted the type to something sensible+-- > addInt = useValue "Prelude" $ Symbol "+"+--+useValue :: String -> Name -> ExpG a+useValue md name = ExpM $ do+  lift $ tell $ S.singleton $ ModuleName md+  return $ Var $ Qual (ModuleName md) name++-- | Import a value constructor from a module. Returns the qualified name of the constructor.+useCon :: String -> Name -> ExpM t QName+useCon md name = ExpM $ do+  lift $ tell $ S.singleton $ ModuleName md+  return $ Qual (ModuleName md) name++-- | Use the value of a variable with the given name.+useVar :: Name -> ExpG t+useVar name = return $ Var $ UnQual name++-- | Generate a new unique variable name with the given prefix. Note that this new variable name+-- is only unique relative to other variable names generated by this function. +newName :: String -> ExpM t Name+newName pref = ExpM $ do+  i <- get <* modify succ+  return $ Ident $ pref ++ show i++-- | This type family can be used to get the type associated with some expression.+type family ExpType a :: *+type instance ExpType (ExpM t a) = t++-- | Generate a expression from a haskell value. +class GenExp t where+  type GenExpType t :: *++  -- | This function generates the haskell expression from the given haskell value.+  expr :: t -> ExpG (GenExpType t)++instance GenExp (ExpG a) where+  type GenExpType (ExpG a) = a+  expr = id++instance GenExp Char where+  type GenExpType Char = Char+  expr = return . Lit . Char++instance GenExp Integer where+  type GenExpType Integer = Integer+  expr = return . Lit . Int++instance GenExp Rational where+  type GenExpType Rational = Rational+  expr = return . Lit . Frac++instance GenExp a => GenExp [a] where+  type GenExpType [a] = [GenExpType a]+  expr = ExpM . fmap List . mapM (unExpM . expr)++instance GenExp x => GenExp (ExpG a -> x) where+  type GenExpType (ExpG a -> x) = a -> GenExpType x+  expr f = do +    pvarName <- newName "pvar_"+    body <- unsafeCoerceE $ expr $ f $ return $ Var $ UnQual pvarName+    return $ Lambda noLoc [PVar pvarName] body++--------------------------------------------------------------------------------+-- Apply functions++-- | Apply a function in a haskell expression to a value.+applyE :: ExpG (a -> b) -> ExpG a -> ExpG b+applyE a b = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b]+  where ce = unsafeCoerceE++-- | Operator for 'applyE'. +(<>$) :: ExpG (a -> b) -> ExpG a -> ExpG b+(<>$) = applyE++infixl 1 <>$++-- | ApplyE for 2 arguments+applyE2 :: ExpG (a -> b -> c) -> ExpG a -> ExpG b -> ExpG c+applyE2 a b c = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c]+  where ce = unsafeCoerceE++-- | Apply a function to 3 arguments+applyE3 :: ExpG (a -> b -> c -> d) -> ExpG a -> ExpG b -> ExpG c -> ExpG d+applyE3 a b c d = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d]+  where ce = unsafeCoerceE++-- | Apply a function to 4 arguments+applyE4 :: ExpG (a -> b -> c -> d -> e) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e+applyE4 a b c d e = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d,ce e]+  where ce = unsafeCoerceE++-- | Apply a function to 5 arguments+applyE5 :: ExpG (a -> b -> c -> d -> e -> f) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e -> ExpG f+applyE5 a b c d e f = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d,ce e,ce f]+  where ce = unsafeCoerceE++-- | Apply a function to 6 arguments+applyE6 :: ExpG (a -> b -> c -> d -> e -> f -> g) -> ExpG a -> ExpG b -> ExpG c -> ExpG d -> ExpG e -> ExpG f -> ExpG g+applyE6 a b c d e f g = unsafeCoerceE $ liftM (foldl1 App) $ sequence [ce a,ce b,ce c,ce d,ce e,ce f,ce g]+  where ce = unsafeCoerceE++--------------------------------------------------------------------------------+-- Generate modules++-- | A module keeps track of the needed imports, but also has a list of declarations in it.+newtype ModuleM a = ModuleM (Writer (S.Set ModuleName, [Decl]) a) deriving (Functor, Applicative, Monad)++-- | This is the resulting type of a function generating a module. It is a ModuleM action returning the export list.+type ModuleG = ModuleM (Maybe [ExportSpec])++-- | A reference to a function. With a reference to a function, you can apply it (by lifting it into ExprT using 'expr') to some value+-- or export it using 'exportFun'.+data FunRef t = FunRef Name++instance GenExp (FunRef t) where+  type GenExpType (FunRef t) = t+  expr (FunRef n) = return $ Var $ UnQual n++-- | Generate a ExportSpec for a given function item.+exportFun :: FunRef t -> ExportSpec +exportFun (FunRef name) = EVar (UnQual name)++-- | Add a declaration to the module. Return a reference to it that can be used to either apply the function to some values or export it.+addDecl :: Name -> ExpG t -> ModuleM (FunRef t)+addDecl name e = ModuleM $ do+  let (body, mods) = runExpM e+  tell (mods, [FunBind [Match noLoc name [] Nothing (UnGuardedRhs body) $ BDecls []]])+  return $ FunRef name++-- | Extract the Module from a module generator.+runModuleM :: ModuleG -> String -> Module+runModuleM (ModuleM act) name = +  Module noLoc (ModuleName name) [] Nothing export (map (\md -> ImportDecl noLoc md True False Nothing Nothing Nothing) $ S.toList imps) decls+  where (export, (imps, decls)) = runWriter act++-- | Generate the source code for a module.+generateModule :: ModuleG -> String -> String+generateModule = fmap prettyPrint . runModuleM

@@ -0,0 +1,94 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+module Language.Haskell.Generate.PreludeDef where++import Language.Haskell.Exts.Syntax+import Language.Haskell.Generate.Base+import Language.Haskell.Generate.TH++--------------------------------------------------------------------------------+-- Basic functions++fmap concat $ mapM declareFunction +  [ 'maybe+  , 'either+  , 'fst+  , 'snd+  , 'curry+  , 'uncurry+  , 'not+  , 'negate, 'abs, 'signum, 'fromInteger+  , 'quot, 'rem, 'div, 'mod, 'quotRem, 'divMod, 'toInteger+  , 'recip, 'fromRational+  , 'pi, 'exp, 'log, 'sqrt, 'logBase, 'sin, 'cos, 'tan+  , 'asin, 'acos, 'atan, 'sinh, 'cosh, 'tanh, 'asinh, 'acosh, 'atanh+  , 'properFraction, 'truncate, 'round, 'ceiling, 'floor+  , 'floatRadix, 'floatDigits, 'floatRange, 'decodeFloat+  , 'encodeFloat, 'exponent, 'significand, 'scaleFloat, 'isNaN+  , 'isInfinite, 'isDenormalized, 'isIEEE, 'isNegativeZero, 'atan2+  , 'subtract, 'even, 'odd, 'gcd, 'lcm+  , 'fromIntegral, 'realToFrac+  , 'fmap, 'return, 'mapM, 'mapM_+  , 'id, 'const, 'flip, 'until, 'asTypeOf, 'undefined+  , 'map, 'filter, 'head, 'last, 'tail, 'init, 'null, 'length+  , 'reverse, 'foldl, 'foldr, 'foldl1, 'foldr1, 'and, 'or, 'any, 'all, 'sum, 'product+  , 'concat, 'concatMap, 'maximum, 'minimum+  , 'scanl, 'scanr, 'scanl1, 'scanr1+  , 'iterate, 'repeat, 'replicate, 'cycle+  , 'take, 'drop, 'splitAt, 'takeWhile, 'dropWhile, 'span, 'break+  , 'elem, 'notElem, 'lookup+  , 'zip, 'zip3, 'zipWith, 'zipWith3, 'unzip, 'unzip3+  , 'lines, 'words, 'unlines, 'unwords+  , 'read, 'show+  , 'putChar, 'putStr, 'putStrLn, 'print+  , 'getChar, 'getLine, 'getContents, 'interact+  , 'readFile, 'writeFile, 'appendFile, 'readIO, 'readLn+  , 'Just, 'Left, 'Right, 'False, 'True, 'Nothing+  ]++fmap concat $ mapM declareNamedSymbol+  [ ('(.), "dot'")+  , ('(+), "add'")+  , ('(*), "mult'")+  , ('(/), "divide'")+  , ('(**), "floatPow'")+  , ('(>>=), "bind'")+  , ('(>>), "then'")+  , ('(++), "append'")+  , ('(!!), "index'")+  , ('(==), "equal'")+  ]++(<>.) :: ExpG (b -> c) -> ExpG (a -> b) -> ExpG (a -> c)+(<>.) a b = dot' <>$ a <>$ b++tuple0 :: ExpG ()+tuple0 = return $ Var $ Special UnitCon++tuple2 :: ExpG (a -> b -> (a,b))+tuple2 = return $ Var $ Special $ TupleCon Boxed 2++tuple3 :: ExpG (a -> b -> c -> (a,b,c))+tuple3 = return $ Var $ Special $ TupleCon Boxed 3++tuple4 :: ExpG (a -> b -> c -> d -> (a,b,c,d))+tuple4 = return $ Var $ Special $ TupleCon Boxed 4++tuple5 :: ExpG (a -> b -> c -> d -> (a,b,c,d,e))+tuple5 = return $ Var $ Special $ TupleCon Boxed 5++cons :: ExpG (a -> [a] -> [a])+cons = return $ Var $ Special Cons++instance Num t => Num (ExpG t) where+  a + b = add'  <>$ a <>$ b+  a - b = flip' <>$ subtract' <>$ a <>$ b+  a * b = mult' <>$ a <>$ b+  negate a = negate' <>$ a+  abs a    = abs'    <>$ a+  fromInteger a = return $ Lit $ Int a+  signum a = signum' <>$ a+

@@ -0,0 +1,52 @@+{-# LANGUAGE TemplateHaskell #-}+module Language.Haskell.Generate.TH +  ( -- | This module provides functions for automagically generating type-safe ExpG definitions from functions. For an example on how to use this, +    -- you can look at the 'Language.Haskell.Generate.Prelude' module.+    declareFunction+  , declareNamedSymbol+  , declareNamedFunction+  , declareNamedThing+  ) where++import Data.Char+import Language.Haskell.Exts.Syntax hiding (Name)+import Language.Haskell.Generate.Base hiding (Name)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++-- | Make a ExpG for the given function, using the given name for the definition.+declareNamedFunction :: (Name, String) -> DecsQ+declareNamedFunction (func, name) = declareNamedThing (func, name, 'Ident)++-- | Make a ExpG for some thing, using the given name for the definition. The third tuple element+-- specifies the constructor to use for constructing the Name. This can either be @'Symbol@ (for symbols)+-- or @'Ident@ (for functions).+declareNamedThing :: (Name, String, Name) -> DecsQ+declareNamedThing (thing, name, thingClass) = do+  info <- reify thing+  typ <- case info of+    VarI _ t _ _ -> return t+    ClassOpI _ t _ _ -> return t+    DataConI _ t _ _ -> return t    +    _ -> fail $ "Not a function: " ++ nameBase thing+  md <- maybe (fail "No module name for function!") return $ nameModule thing+  sequence+    [ sigD (mkName name) $ return $ overQuantifiedType (ConT ''ExpG `AppT`) typ+    , funD (mkName name) $ return $ flip (clause []) [] $ normalB +        [| useValue $(lift md) $ $(conE thingClass) $(lift $ nameBase thing) |]+    ]++  where overQuantifiedType f (ForallT bnds ctx t) = ForallT bnds ctx $ overQuantifiedType f t+        overQuantifiedType f x = f x++-- | Declare a symbol, using the given name for the definition.+declareNamedSymbol :: (Name, String) -> DecsQ+declareNamedSymbol (func, name) = declareNamedThing (func, name, 'Symbol)++-- | Declare a function. The name of the definition will be the name of the function with an added apostrophe. (Example: declareFunction 'add generates +-- a definition with the name add').+declareFunction :: Name -> DecsQ+declareFunction func = declareNamedFunction (func, funcName ++ "'")+  where funcName = case nameBase func of+          (h:t) -> toLower h:t+          x     -> x

@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- Copyright   :  (C) 2012-13 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##ifdef mingw32_HOST_ARCH+##ifdef i386_HOST_ARCH+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+  cp <- c_GetConsoleCP+  (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ forM_ deps $ \(dirs, dep) -> do+    putStrLn $ ":: Running doctests for source directories: " ++ intercalate " " dirs+    mapM getSources dirs >>= \sources -> doctest $+        "-idist/build/autogen"+      : "-optP-include"+      : "-optPdist/build/autogen/cabal_macros.h"+      : "-hide-all-packages"+      : map ("-package="++) dep+        ++ map ("-i"++) dirs +        ++ join sources ++getSources :: FilePath -> IO [FilePath]+getSources d = filter (isSuffixOf ".hs") <$> go d+  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