haskell-tools-refactor 1.0.0.4 → 1.0.1.1

raw patch · 167 files changed

+3747/−42 lines, 167 filesdep +aesondep +eitherdep +haskell-tools-refactordep ~CabalPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, either, haskell-tools-refactor, old-time, polyparse, tasty, tasty-hunit, time

Dependency ranges changed: Cabal

API changes (from Hackage documentation)

Files

• Language/Haskell/Tools/Refactor.hs +14/−5
• Language/Haskell/Tools/Refactor/Monad.hs +6/−0
• Language/Haskell/Tools/Refactor/Prepare.hs +23/−19
• Language/Haskell/Tools/Refactor/Querying.hs +40/−0
• Language/Haskell/Tools/Refactor/Refactoring.hs +1/−0
• Language/Haskell/Tools/Refactor/Representation.hs +1/−0
• Language/Haskell/Tools/Refactor/Utils/AST.hs +1/−0
• Language/Haskell/Tools/Refactor/Utils/BindingElem.hs +2/−1
• Language/Haskell/Tools/Refactor/Utils/Extensions.hs +17/−2
• Language/Haskell/Tools/Refactor/Utils/Helpers.hs +1/−0
• Language/Haskell/Tools/Refactor/Utils/Lists.hs +1/−0
• Language/Haskell/Tools/Refactor/Utils/Maybe.hs +18/−0
• Language/Haskell/Tools/Refactor/Utils/Monadic.hs +5/−4
• Language/Haskell/Tools/Refactor/Utils/Name.hs +1/−0
• Language/Haskell/Tools/Refactor/Utils/NameLookup.hs +26/−0
• Language/Haskell/Tools/Refactor/Utils/Type.hs +205/−0
• Language/Haskell/Tools/Refactor/Utils/TypeLookup.hs +154/−0
• examples/CPP/ConditionalCode.hs +8/−0
• examples/CPP/JustEnabled.hs +2/−0
• examples/CommentHandling/BlockComments.hs +10/−0
• examples/CommentHandling/CommentTypes.hs +10/−0
• examples/CommentHandling/Crosslinking.hs +6/−0
• examples/CommentHandling/FunctionArgs.hs +6/−0
• examples/CppHs/Language/Preprocessor/Cpphs.hs +34/−0
• examples/CppHs/Language/Preprocessor/Cpphs/CppIfdef.hs +416/−0
• examples/CppHs/Language/Preprocessor/Cpphs/HashDefine.hs +129/−0
• examples/CppHs/Language/Preprocessor/Cpphs/MacroPass.hs +184/−0
• examples/CppHs/Language/Preprocessor/Cpphs/Options.hs +156/−0
• examples/CppHs/Language/Preprocessor/Cpphs/Position.hs +106/−0
• examples/CppHs/Language/Preprocessor/Cpphs/ReadFirst.hs +55/−0
• examples/CppHs/Language/Preprocessor/Cpphs/RunCpphs.hs +82/−0
• examples/CppHs/Language/Preprocessor/Cpphs/SymTab.hs +92/−0
• examples/CppHs/Language/Preprocessor/Cpphs/Tokenise.hs +281/−0
• examples/CppHs/Language/Preprocessor/Unlit.hs +72/−0
• examples/Decl/AmbiguousFields.hs +9/−0
• examples/Decl/AnnPragma.hs +8/−0
• examples/Decl/ClassInfix.hs +10/−0
• examples/Decl/ClosedTypeFamily.hs +9/−0
• examples/Decl/CompletePragma.hs +16/−0
• examples/Decl/CtorOp.hs +10/−0
• examples/Decl/DataFamily.hs +6/−0
• examples/Decl/DataInstanceGADT.hs +6/−0
• examples/Decl/DataType.hs +5/−0
• examples/Decl/DataTypeDerivings.hs +5/−0
• examples/Decl/DefaultDecl.hs +3/−0
• examples/Decl/FunBind.hs +4/−0
• examples/Decl/FunFixity.hs +5/−0
• examples/Decl/FunGuards.hs +5/−0
• examples/Decl/FunctionalDeps.hs +6/−0
• examples/Decl/GADT.hs +9/−0
• examples/Decl/GadtConWithCtx.hs +5/−0
• examples/Decl/InfixAssertion.hs +9/−0
• examples/Decl/InfixInstances.hs +8/−0
• examples/Decl/InfixPatSyn.hs +10/−0
• examples/Decl/InjectiveTypeFamily.hs +6/−0
• examples/Decl/InlinePragma.hs +5/−0
• examples/Decl/InstanceFamily.hs +10/−0
• examples/Decl/InstanceOverlaps.hs +11/−0
• examples/Decl/InstanceSpec.hs +7/−0
• examples/Decl/LocalBindingInDo.hs +7/−0
• examples/Decl/LocalBindings.hs +9/−0
• examples/Decl/LocalFixity.hs +6/−0
• examples/Decl/MinimalPragma.hs +23/−0
• examples/Decl/MixedInstance.hs +11/−0
• examples/Decl/MultipleFixity.hs +12/−0
• examples/Decl/MultipleSigs.hs +6/−0
• examples/Decl/OperatorBind.hs +6/−0
• examples/Decl/OperatorDecl.hs +6/−0
• examples/Decl/ParamDataType.hs +5/−0
• examples/Decl/PatternBind.hs +3/−0
• examples/Decl/PatternSynonym.hs +28/−0
• examples/Decl/RecordPatternSynonyms.hs +8/−0
• examples/Decl/RecordType.hs +3/−0
• examples/Decl/RewriteRule.hs +3/−0
• examples/Decl/SpecializePragma.hs +5/−0
• examples/Decl/StandaloneDeriving.hs +6/−0
• examples/Decl/TypeClass.hs +13/−0
• examples/Decl/TypeClassMinimal.hs +8/−0
• examples/Decl/TypeFamily.hs +6/−0
• examples/Decl/TypeFamilyKindSig.hs +6/−0
• examples/Decl/TypeInstance.hs +14/−0
• examples/Decl/TypeRole.hs +5/−0
• examples/Decl/TypeSynonym.hs +3/−0
• examples/Decl/ValBind.hs +3/−0
• examples/Decl/ViewPatternSynonym.hs +8/−0
• examples/Expr/ArrowNotation.hs +10/−0
• examples/Expr/Case.hs +8/−0
• examples/Expr/DoNotation.hs +15/−0
• examples/Expr/EmptyCase.hs +8/−0
• examples/Expr/EmptyLet.hs +6/−0
• examples/Expr/FunSection.hs +6/−0
• examples/Expr/GeneralizedListComp.hs +31/−0
• examples/Expr/If.hs +4/−0
• examples/Expr/LambdaCase.hs +11/−0
• examples/Expr/ListComp.hs +3/−0
• examples/Expr/MultiwayIf.hs +7/−0
• examples/Expr/Negate.hs +4/−0
• examples/Expr/Operator.hs +5/−0
• examples/Expr/ParListComp.hs +4/−0
• examples/Expr/ParenName.hs +3/−0
• examples/Expr/PatternAndDo.hs +10/−0
• examples/Expr/RecordPuns.hs +6/−0
• examples/Expr/RecordWildcards.hs +6/−0
• examples/Expr/RecursiveDo.hs +9/−0
• examples/Expr/SccPragma.hs +4/−0
• examples/Expr/Sections.hs +4/−0
• examples/Expr/SemicolonDo.hs +7/−0
• examples/Expr/StaticPtr.hs +16/−0
• examples/Expr/TupleSections.hs +7/−0
• examples/Expr/UnboxedSum.hs +13/−0
• examples/Expr/UnicodeSyntax.hs +7/−0
• examples/InstanceControl/Control/Instances/Morph.hs +149/−0
• examples/InstanceControl/Control/Instances/ShortestPath.hs +69/−0
• examples/InstanceControl/Control/Instances/Test.hs +23/−0
• examples/InstanceControl/Control/Instances/TypeLevelPrelude.hs +88/−0
• examples/Module/DeprecatedPragma.hs +1/−0
• examples/Module/Export.hs +2/−0
• examples/Module/ExportModifiers.hs +4/−0
• examples/Module/ExportSubs.hs +3/−0
• examples/Module/GhcOptionsPragma.hs +2/−0
• examples/Module/Import.hs +11/−0
• examples/Module/ImportOp.hs +3/−0
• examples/Module/Imported.hs +6/−0
• examples/Module/LangPragmas.hs +4/−0
• examples/Module/NamespaceExport.hs +4/−0
• examples/Module/PatternImport.hs +4/−0
• examples/Module/Simple.hs +1/−0
• examples/Module/WarningPragma.hs +1/−0
• examples/Pattern/Backtick.hs +5/−0
• examples/Pattern/Constructor.hs +3/−0
• examples/Pattern/ImplicitParams.hs +9/−0
• examples/Pattern/Infix.hs +5/−0
• examples/Pattern/NPlusK.hs +6/−0
• examples/Pattern/NestedWildcard.hs +7/−0
• examples/Pattern/OperatorPattern.hs +3/−0
• examples/Pattern/Record.hs +11/−0
• examples/Pattern/UnboxedSum.hs +6/−0
• examples/TH/Brackets.hs +19/−0
• examples/TH/ClassUse.hs +10/−0
• examples/TH/CrossDef.hs +4/−0
• examples/TH/DoubleSplice.hs +4/−0
• examples/TH/GADTFields.hs +7/−0
• examples/TH/LocalDefinition.hs +19/−0
• examples/TH/MultiImport.hs +7/−0
• examples/TH/NestedSplices.hs +6/−0
• examples/TH/QuasiQuote/Define.hs +8/−0
• examples/TH/QuasiQuote/Use.hs +11/−0
• examples/TH/Quoted.hs +6/−0
• examples/TH/Splice/Define.hs +24/−0
• examples/TH/Splice/Names.hs +12/−0
• examples/TH/Splice/Use.hs +22/−0
• examples/TH/Splice/UseImported.hs +9/−0
• examples/TH/Splice/UseQual.hs +6/−0
• examples/TH/Splice/UseQualMulti.hs +8/−0
• examples/TH/WithWildcards.hs +8/−0
• examples/Type/Bang.hs +4/−0
• examples/Type/Builtin.hs +20/−0
• examples/Type/Ctx.hs +10/−0
• examples/Type/ExplicitTypeApplication.hs +7/−0
• examples/Type/Forall.hs +11/−0
• examples/Type/Primitives.hs +10/−0
• examples/Type/TupleAssert.hs +5/−0
• examples/Type/TypeOperators.hs +10/−0
• examples/Type/Unpack.hs +4/−0
• examples/Type/Wildcard.hs +7/−0
• haskell-tools-refactor.cabal +64/−11
• test/Main.hs +196/−0

@@ -5,17 +5,21 @@     , module Language.Haskell.Tools.AST.References
     , module Language.Haskell.Tools.AST.Helpers
     , module Language.Haskell.Tools.Refactor.Utils.Monadic
-  , module Language.Haskell.Tools.Refactor.Utils.Helpers
+    , module Language.Haskell.Tools.Refactor.Utils.Helpers
     , module Language.Haskell.Tools.Rewrite.ElementTypes
     , module Language.Haskell.Tools.Refactor.Prepare
     , module Language.Haskell.Tools.Refactor.Utils.Lists
     , module Language.Haskell.Tools.Refactor.Utils.BindingElem
     , module Language.Haskell.Tools.Refactor.Utils.Indentation
+    , module Language.Haskell.Tools.Refactor.Querying
     , module Language.Haskell.Tools.Refactor.Refactoring
     , module Language.Haskell.Tools.Refactor.Utils.Name
     , module Language.Haskell.Tools.Refactor.Representation
     , module Language.Haskell.Tools.Refactor.Monad
-  , Ann, HasSourceInfo(..), HasRange(..), annListElems, annListAnnot, annList, annJust, annMaybe, isAnnNothing, Domain, Dom, IdDom
+    , module Language.Haskell.Tools.Refactor.Utils.Type
+    , module Language.Haskell.Tools.Refactor.Utils.TypeLookup
+    , module Language.Haskell.Tools.Refactor.Utils.NameLookup
+    , Ann, HasSourceInfo(..), HasRange(..), annListElems, annListAnnot, annList, annJust, annMaybe, isAnnNothing, Domain, Dom, IdDom
     , shortShowSpan, shortShowSpanWithFile, SrcTemplateStage, SourceInfoTraversal(..)
     -- elements of source templates
     , sourceTemplateNodeRange, sourceTemplateNodeElems
@@ -31,20 +35,25 @@ import Language.Haskell.Tools.AST.Helpers
 import Language.Haskell.Tools.AST.References
 import Language.Haskell.Tools.AST.SemaInfoClasses
-import Language.Haskell.Tools.BackendGHC (SpliceInsertionProblem(..), ConvertionProblem(..))
-import Language.Haskell.Tools.PrettyPrint (PrettyPrintProblem(..))
 import Language.Haskell.Tools.PrettyPrint.Prepare
 import Language.Haskell.Tools.Refactor.Monad
-import Language.Haskell.Tools.Refactor.Prepare
+import Language.Haskell.Tools.Refactor.Prepare hiding (ModuleName)
 import Language.Haskell.Tools.Refactor.Refactoring
 import Language.Haskell.Tools.Refactor.Representation
 import Language.Haskell.Tools.Refactor.Utils.BindingElem
 import Language.Haskell.Tools.Refactor.Utils.Helpers
 import Language.Haskell.Tools.Refactor.Utils.Indentation
 import Language.Haskell.Tools.Refactor.Utils.Lists
+import Language.Haskell.Tools.Refactor.Utils.Maybe
 import Language.Haskell.Tools.Refactor.Utils.Monadic
 import Language.Haskell.Tools.Refactor.Utils.Name
+import Language.Haskell.Tools.Refactor.Utils.NameLookup
+import Language.Haskell.Tools.Refactor.Utils.Type
+import Language.Haskell.Tools.Refactor.Utils.TypeLookup
+import Language.Haskell.Tools.Refactor.Querying
 import Language.Haskell.Tools.Rewrite
 import Language.Haskell.Tools.Rewrite.ElementTypes
 
 import Language.Haskell.Tools.AST.Ann
+import Language.Haskell.Tools.BackendGHC (SpliceInsertionProblem(..), ConvertionProblem(..))
+import Language.Haskell.Tools.PrettyPrint (PrettyPrintProblem(..))

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}
+
 -- | Types and instances for monadic refactorings. The refactoring monad provides automatic
 -- importing, keeping important source fragments (such as preprocessor pragmas), and providing
 -- contextual information for refactorings.
@@ -11,6 +12,7 @@ import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
 import Control.Monad.Trans.Reader (ReaderT(..))
 import Control.Monad.Trans.Writer (WriterT(..))
+import Control.Monad.Trans.Maybe  (MaybeT(..))
 import Control.Monad.Writer
 import DynFlags (HasDynFlags(..))
 import Exception (ExceptionMonad(..))
@@ -122,3 +124,7 @@ instance ExceptionMonad m => ExceptionMonad (ExceptT s m) where
   gcatch e c = ExceptT (runExceptT e `gcatch` (runExceptT . c))
   gmask m = ExceptT $ gmask (\f -> runExceptT $ m (ExceptT . f . runExceptT))
+
+instance (ExceptionMonad m) => ExceptionMonad (MaybeT m) where
+  gcatch action handler = MaybeT $ runMaybeT action `gcatch` (runMaybeT . handler)
+  gmask m = MaybeT $ gmask (\f -> runMaybeT $ m (\x -> MaybeT . f . runMaybeT $ x))

@@ -1,11 +1,11 @@-{-# LANGUAGE FlexibleContexts, LambdaCase, MultiWayIf, ScopedTypeVariables, TypeFamilies, TupleSections #-}
+{-# LANGUAGE FlexibleContexts, LambdaCase, MonoLocalBinds, ScopedTypeVariables #-}+
 -- | Defines utility methods that prepare Haskell modules for refactoring
 module Language.Haskell.Tools.Refactor.Prepare where
 
 import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class (MonadIO(..))
-import Data.IORef
 import Data.List ((\\), isSuffixOf)
 import Data.List.Split (splitOn)
 import Data.Maybe (Maybe(..), fromMaybe, fromJust)
@@ -16,15 +16,11 @@ import CmdLineParser (CmdLineP(..), processArgs)
 import DynFlags
 import FastString (mkFastString)
-import GHC hiding (loadModule)
+import GHC hiding (loadModule, ModuleName)
 import qualified GHC (loadModule)
 import GHC.Paths ( libdir )
 import GhcMonad
 import HscTypes
-import TcRnTypes
-import TcRnMonad
-import TcRnDriver
-import Linker (unload)
 import Outputable (Outputable(..), showSDocUnsafe)
 import Packages (initPackages)
 import SrcLoc
@@ -38,9 +34,12 @@ import Language.Haskell.Tools.Refactor.Representation
 import Language.Haskell.Tools.Refactor.Utils.Monadic (runRefactor)
 
+-- | Type synonym for module names.
+type ModuleName = String
 
+
 -- | A quick function to try the refactorings
-tryRefactor :: (RealSrcSpan -> Refactoring) -> String -> String -> IO ()
+tryRefactor :: (RealSrcSpan -> Refactoring) -> String -> ModuleName -> IO ()
 tryRefactor refact moduleName span
   = runGhc (Just libdir) $ do
       initGhcFlags
@@ -68,13 +67,13 @@   dynflags <- getSessionDynFlags
   let change = runCmdLine $ processArgs flagsAll lArgs
   let ((leftovers, errs, warnings), newDynFlags) = change dynflags
-  when (not (null warnings))
+  unless (null warnings)
     $ liftIO $ putStrLn $ showSDocUnsafe $ ppr warnings
-  when (not (null errs))
+  unless (null errs)
     $ liftIO $ putStrLn $ showSDocUnsafe $ ppr errs
   void $ setSessionDynFlags newDynFlags
   when (any ("-package-db" `isSuffixOf`) args) reloadPkgDb
-  return $ (map unLoc leftovers, snd . change)
+  return (map unLoc leftovers, snd . change)
 
 -- | Reloads the package database based on the session flags
 reloadPkgDb :: Ghc ()
@@ -94,14 +93,12 @@ initGhcFlags' :: Bool -> Bool -> Ghc ()
 initGhcFlags' needsCodeGen errorsSuppressed = do
   dflags <- getSessionDynFlags
-  env <- getSession
-  liftIO $ unload env [] -- clear linker state if ghc was used in the same process
   void $ setSessionDynFlags
     $ flip gopt_set Opt_KeepRawTokenStream
     $ flip gopt_set Opt_NoHsMain
     $ (if errorsSuppressed then flip gopt_set Opt_DeferTypeErrors
-                                  . flip gopt_set Opt_DeferTypedHoles	 
-                                  . flip gopt_set Opt_DeferOutOfScopeVariables 
+                                  . flip gopt_set Opt_DeferTypedHoles
+                                  . flip gopt_set Opt_DeferOutOfScopeVariables
                            else id)
     $ dflags { importPaths = []
              , hscTarget = if needsCodeGen then HscInterpreted else HscNothing
@@ -123,11 +120,11 @@   void $ setSessionDynFlags dynflags { importPaths = importPaths dynflags \\ workingDirs }
 
 -- | Translates module name and working directory into the name of the file where the given module should be defined
-toFileName :: FilePath -> String -> FilePath
+toFileName :: FilePath -> ModuleName -> FilePath
 toFileName workingDir mod = normalise $ workingDir </> map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs"
 
 -- | Translates module name and working directory into the name of the file where the boot module should be defined
-toBootFileName :: FilePath -> String -> FilePath
+toBootFileName :: FilePath -> ModuleName -> FilePath
 toBootFileName workingDir mod = normalise $ workingDir </> map (\case '.' -> pathSeparator; c -> c) mod ++ ".hs-boot"
 
 -- | Get the source directory where the module is located.
@@ -150,8 +147,15 @@ getModSumName :: ModSummary -> String
 getModSumName = GHC.moduleNameString . moduleName . ms_mod
 
+-- | Load the AST of a module given by the working directory and module name.
+loadModuleAST :: FilePath -> ModuleName -> Ghc TypedModule
+loadModuleAST workingDir moduleName = do
+  useFlags ["-w"]
+  modSummary <- loadModule workingDir moduleName
+  parseTyped modSummary
+
 -- | Load the summary of a module given by the working directory and module name.
-loadModule :: String -> String -> Ghc ModSummary
+loadModule :: FilePath -> ModuleName -> Ghc ModSummary
 loadModule workingDir moduleName
   = do initGhcFlagsForTest
        useDirs [workingDir]
@@ -178,7 +182,7 @@   srcBuffer <- if hasCppExtension
                     then liftIO $ hGetStringBuffer (getModSumOrig ms)
                     else return (fromJust $ ms_hspp_buf $ pm_mod_summary p)
-  withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) 
+  withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms })
     $ (if hasCppExtension then prepareASTCpp else prepareAST) srcBuffer . placeComments (fst annots) (getNormalComments $ snd annots)
         <$> (addTypeInfos (typecheckedSource tc)
                =<< (do parseTrf <- runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModule ms (pm_parsed_source p)

@@ -0,0 +1,40 @@+module Language.Haskell.Tools.Refactor.Querying where
+
+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
+import Data.List ((++), map, find)
+import Data.Aeson (Value)
+
+import GHC (RealSrcSpan, Ghc)
+
+import Language.Haskell.Tools.AST ()
+import Language.Haskell.Tools.Refactor.Monad (ProjectRefactoring, Refactoring)
+import Language.Haskell.Tools.Refactor.Prepare (correctRefactorSpan, readSrcSpan)
+import Language.Haskell.Tools.Refactor.Representation (RefactorChange, ModuleDom)
+
+data QueryChoice = LocationQuery
+                     { queryName :: String
+                     , locationQuery :: RealSrcSpan -> ModuleDom -> [ModuleDom] -> QueryMonad Value
+                     }
+
+type QueryMonad = ExceptT String Ghc
+
+queryCommands :: [QueryChoice] -> [String]
+queryCommands = map queryName
+
+queryError :: String -> QueryMonad a
+queryError = throwE
+
+performQuery :: [QueryChoice] -- ^ The set of available queries
+                  -> [String] -- ^ The query command
+                  -> Either FilePath ModuleDom -- ^ The module in which the refactoring is performed
+                  -> [ModuleDom] -- ^ Other modules
+                  -> Ghc (Either String Value)
+performQuery queries (name:args) mod mods =
+  case (query, mod, args) of
+    (Just (LocationQuery _ query), Right mod, sp:_)
+      -> runExceptT $ query (correctRefactorSpan (snd mod) $ readSrcSpan sp) mod mods
+    (Just (LocationQuery _ query), _, _)
+      -> return $ Left $ "The query '" ++ name ++ "' needs one argument: a source range"
+    (Nothing, _, _)
+      -> return $ Left $ "Unknown command: " ++ name
+  where query = find ((== name) . queryName) queries

@@ -4,6 +4,7 @@ 
 import Control.Monad.Trans.Except (runExceptT)
 import Data.List ((++), map, find)
+import Data.Aeson (Value)
 
 import GHC (RealSrcSpan, Ghc)
 

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances, TemplateHaskell #-}
+
 -- | Representation of modules, their collections, refactoring changes and exceptions.
 module Language.Haskell.Tools.Refactor.Representation where
 

@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes, LambdaCase #-}
+
 -- | Operations for changing the AST
 module Language.Haskell.Tools.Refactor.Utils.AST (removeChild, removeSeparator) where
 

@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts, MonoLocalBinds #-}
+
 -- | Utilities for transformations that work on both top-level and local definitions
 module Language.Haskell.Tools.Refactor.Utils.BindingElem where
 

@@ -1,13 +1,16 @@  -- all extensions should be matched
 
-module Language.Haskell.Tools.Refactor.Utils.Extensions where
+module Language.Haskell.Tools.Refactor.Utils.Extensions
+  ( module Language.Haskell.Tools.Refactor.Utils.Extensions
+  , GHC.Extension(..)
+  ) where
 
 import Control.Reference ((^.), _1, _2, _3)
 import Language.Haskell.Extension (KnownExtension(..))
 import qualified Language.Haskell.TH.LanguageExtensions as GHC (Extension(..))
 
 
-
+-- | Expands an extension into all the extensions it implies (keeps original as well)
 expandExtension :: GHC.Extension -> [GHC.Extension]
 expandExtension ext = ext : implied
   where fst' = (^. _1) :: (a,b,c) -> a
@@ -16,6 +19,10 @@ 
         implied = map trd' . filter snd' . filter ((== ext) . fst') $ impliedXFlags
 
+-- | Replaces deprecated extensions with their new counterpart
+replaceDeprecated :: GHC.Extension -> GHC.Extension
+replaceDeprecated GHC.NullaryTypeClasses = GHC.MultiParamTypeClasses
+replaceDeprecated x = x
 
 turnOn  = True
 turnOff = False
@@ -52,6 +59,14 @@     , (GHC.TemplateHaskell,           turnOn,  GHC.TemplateHaskellQuotes)
     , (GHC.Strict,                    turnOn,  GHC.StrictData)
     ]
+
+-- | Canonicalize extensions
+canonExt :: String -> String
+canonExt "CPP" = "Cpp"
+canonExt "Rank2Types" = "RankNTypes"
+canonExt "NamedFieldPuns" = "RecordPuns"
+canonExt "GeneralisedNewtypeDeriving" = "GeneralizedNewtypeDeriving"
+canonExt e = e
 
 -- * Mapping of Cabal haskell extensions to their GHC counterpart
 

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts, LambdaCase, RankNTypes #-}
+
 -- | Helper functions for defining refactorings.
 module Language.Haskell.Tools.Refactor.Utils.Helpers where
 

@@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-}
+
 -- | Defines operation on AST lists.
 -- AST lists carry source information so simple list modification is not enough.
 module Language.Haskell.Tools.Refactor.Utils.Lists where

@@ -0,0 +1,18 @@+module Language.Haskell.Tools.Refactor.Utils.Maybe
+ ( module Language.Haskell.Tools.Refactor.Utils.Maybe
+ , module Data.Maybe
+ , MaybeT(..)
+ ) where
+
+import Data.Maybe
+import Control.Monad
+import Control.Monad.Trans.Maybe (MaybeT(..))
+
+liftMaybe :: (Monad m) => Maybe a -> MaybeT m a
+liftMaybe = MaybeT . return
+
+maybeT :: Monad m => b -> (a -> b) -> MaybeT m a -> m b
+maybeT def f x = liftM (maybe def f) (runMaybeT x)
+
+maybeTM :: Monad m => m b -> (a -> m b) -> MaybeT m a -> m b
+maybeTM def f x = runMaybeT x >>= maybe def f

@@ -1,11 +1,12 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiWayIf, TypeApplications, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts, MonoLocalBinds, MultiWayIf, TypeApplications #-}
+
 -- | Basic utilities and types for defining refactorings.
 module Language.Haskell.Tools.Refactor.Utils.Monadic where
 
 import Control.Monad.Reader (Monad(..), ReaderT(..), MonadReader(..))
 import Control.Monad.State.Strict
+import Control.Monad.Writer
 import Control.Monad.Trans.Except (runExceptT)
-import Control.Monad.Writer (Monad(..), WriterT(..), MonadWriter(..))
 import Control.Reference hiding (element)
 import Data.Either
 import Data.Function (on)
@@ -146,7 +147,7 @@ referenceOperator = referenceName' mkQualOp'
 
 -- | Create a name that references the definition. Generates an import if the definition is not yet imported.
-referenceName' :: ([String] -> GHC.Name -> Ann nt IdDom SrcTemplateStage) -> GHC.Name 
+referenceName' :: ([String] -> GHC.Name -> Ann nt IdDom SrcTemplateStage) -> GHC.Name
                     -> LocalRefactor (Ann nt IdDom SrcTemplateStage)
 referenceName' makeName name
   | name `elem` registeredNamesFromPrelude || qualifiedName name `elem` otherNamesFromPrelude
@@ -165,7 +166,7 @@   where moduleParts = maybe [] (splitOn "." . GHC.moduleNameString . GHC.moduleName) . GHC.nameModule_maybe
 
 -- | Reference the name by the shortest suitable import
-referenceBy :: ([String] -> GHC.Name -> Ann nt IdDom SrcTemplateStage) -> GHC.Name 
+referenceBy :: ([String] -> GHC.Name -> Ann nt IdDom SrcTemplateStage) -> GHC.Name
                  -> [Ann UImportDecl IdDom SrcTemplateStage] -> Ann nt IdDom SrcTemplateStage
 referenceBy makeName name imps =
   let prefixes = map importQualifier imps

@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}
+
 -- | Defines utility operations on Haskell names such as checking if a given identifier is a
 -- correct name for a certain kind of Haskell construct.
 module Language.Haskell.Tools.Refactor.Utils.Name where

@@ -0,0 +1,26 @@+module Language.Haskell.Tools.Refactor.Utils.NameLookup where
+
+import GHC (GhcMonad)
+import qualified GHC
+
+import Control.Reference ((^.))
+
+import Language.Haskell.Tools.AST
+import Language.Haskell.Tools.Rewrite
+import Language.Haskell.Tools.Refactor.Utils.Maybe
+
+
+opSemName :: GhcMonad m => Operator -> MaybeT m GHC.Name
+opSemName = liftMaybe . semanticsName . (^. operatorName)
+
+declHeadSemName :: GhcMonad m => DeclHead -> MaybeT m GHC.Name
+declHeadSemName (NameDeclHead n)       = liftMaybe . semanticsName $ n
+declHeadSemName (ParenDeclHead dh)     = declHeadSemName dh
+declHeadSemName (DeclHeadApp dh _)     = declHeadSemName dh
+declHeadSemName (InfixDeclHead _ op _) = opSemName op
+
+instHeadSemName :: GhcMonad m => InstanceHead -> MaybeT m GHC.Name
+instHeadSemName (InstanceHead n)         = liftMaybe . semanticsName $ n
+instHeadSemName (InfixInstanceHead _ op) = opSemName op
+instHeadSemName (ParenInstanceHead ih)   = instHeadSemName ih
+instHeadSemName (AppInstanceHead ih _)   = instHeadSemName ih

@@ -0,0 +1,205 @@+{-# LANGUAGE FlexibleContexts, MonoLocalBinds, RankNTypes, ScopedTypeVariables, TypeApplications #-}
+
+module Language.Haskell.Tools.Refactor.Utils.Type (typeExpr, appTypeMatches, literalType) where
+
+import Data.List
+import Control.Monad.State
+import Control.Reference
+
+import GHC
+import Module as GHC
+import InstEnv as GHC
+import Unify as GHC
+import Type as GHC
+import Name as GHC
+import Var as GHC
+import UniqSupply as GHC
+import Unique as GHC
+import TysWiredIn as GHC
+import TysPrim as GHC
+import PrelNames as GHC
+import ConLike as GHC
+import PatSyn as GHC
+import BasicTypes as GHC
+
+import Language.Haskell.Tools.Rewrite.ElementTypes as AST
+import Language.Haskell.Tools.Rewrite.Match as AST
+import Language.Haskell.Tools.AST as AST
+
+typeExpr :: Expr -> Ghc GHC.Type
+typeExpr e = do usupp <- liftIO $ mkSplitUniqSupply 'z'
+                evalStateT (typeExpr' e) (uniqsFromSupply usupp)
+
+typeExpr' :: Expr -> StateT [Unique] Ghc GHC.Type
+typeExpr' (Var n) = return $ idType $ semanticsId (n ^. simpleName)
+typeExpr' (Lit l) = literalType' l
+typeExpr' (InfixApp lhs op rhs) = do
+  lhsType <- typeExpr' lhs
+  rhsType <- typeExpr' rhs
+  let opType = idType $ semanticsId (op ^. operatorName)
+  let (opt, repack) = splitType' opType
+  case splitFunTys opt of
+    (lhsT:rhsT:rest, resTyp) -> do
+      let subst = tcUnifyTys (\_ -> BindMe) [lhsType, rhsType] [lhsT, rhsT]
+      return $ maybe id substTy subst $ repack (mkFunTys rest resTyp)
+    _ -> resultType
+typeExpr' (PrefixApp op rhs) = do
+  let opType = idType $ semanticsId (op ^. operatorName)
+  argType <- typeExpr' rhs
+  let (ft, repack) = splitType' opType
+  case splitFunTy_maybe ft of
+    Just (argTyp, resTyp) -> do
+      let subst = tcUnifyTy argType argTyp
+      return $ maybe id substTy subst $ repack resTyp
+    _ -> resultType
+typeExpr' (App f arg) = do
+  argType <- typeExpr' arg
+  funType <- typeExpr' f
+  let (ft, repack) = splitType' funType
+  case splitFunTy_maybe ft of
+    Just (argTyp, resTyp) -> do
+      let subst = tcUnifyTy argType argTyp
+      return $ maybe id substTy subst $ repack resTyp
+    Nothing -> return funType
+typeExpr' (Lambda args e) = do
+  (resType, recomp) <- splitType' <$> typeExpr' e
+  (argTypes, recomps) <- unzip <$> mapM (\_ -> splitType' <$> resultType) (args ^? annList)
+  return $ foldr (.) recomp recomps $ mkFunTys argTypes resType
+typeExpr' (Let _ e) = typeExpr' e
+typeExpr' (If _ then' _) = typeExpr' then'
+typeExpr' (MultiIf alts) =
+  case alts ^? annList & caseGuardExpr of e:_ -> typeExpr' e
+                                          _   -> resultType
+typeExpr' (Case _ alts) =
+  case alts ^? annList & altRhs & rhsCaseExpr of e:_ -> typeExpr' e
+                                                 _   -> resultType
+typeExpr' (Do stmts) =
+  case stmts ^? annList & stmtExpr of e:_ -> typeExpr' e
+                                      _   -> resultType
+typeExpr' (Tuple elems) = do
+  (elemTypes, pack) <- unzip . map splitType' <$> mapM typeExpr' (elems ^? annList)
+  return $ foldr (.) id pack $ mkTupleTy Boxed elemTypes
+typeExpr' (AST.UnboxedTuple elems) = do
+  (elemTypes, pack) <- unzip . map splitType' <$> mapM typeExpr' (elems ^? annList)
+  return $ foldr (.) id pack $ mkTupleTy Unboxed elemTypes
+-- typeExpr' (TupleSection elems) 
+--   = let (elems, holes) <- partition (\case Present _ -> True; Missing -> False) elems
+--      in do args <- mapM resultType holes
+-- 
+-- typeExpr' (UnboxedTupSec elems) = 
+typeExpr' (List elems) = do
+  case elems ^? annList of []  -> do (typ, pack) <- splitType' <$> resultType
+                                     return $ pack $ mkListTy typ
+                           e:_ -> do (typ, pack) <- splitType' <$> typeExpr' e
+                                     return $ pack $ mkListTy typ
+typeExpr' (ParArray elems) = do
+  case elems ^? annList of []  -> do (typ, pack) <- splitType' <$> resultType
+                                     return $ pack $ mkPArrTy typ
+                           e:_ -> do (typ, pack) <- splitType' <$> typeExpr' e
+                                     return $ pack $ mkPArrTy typ
+typeExpr' (Paren inner) = typeExpr' inner
+typeExpr' (LeftSection lhs op) = do
+  let opType = idType $ semanticsId (op ^. operatorName)
+  argType <- typeExpr' lhs
+  let (ft, repack) = splitType' opType
+  case splitFunTy_maybe ft of 
+    Just (argTyp, resTyp) -> do
+      let subst = tcUnifyTy argType argTyp
+      return $ maybe id substTy subst $ repack resTyp
+    _ -> resultType
+typeExpr' (RightSection op rhs) = do
+  let opType = idType $ semanticsId (op ^. operatorName)
+  argType <- typeExpr' rhs
+  let (ft, repack) = splitType' opType
+  case splitFunTys ft of 
+    (arg1:arg2:rest, resTyp) -> do 
+      let subst = tcUnifyTy arg2 argType
+      return $ maybe id substTy subst $ repack (mkFunTys (arg1:rest) resTyp)
+    _ -> resultType
+typeExpr' (AST.RecCon name _) 
+  = do def <- lift $ maybe (return Nothing) GHC.lookupName (semanticsName (name ^. simpleName))
+       case def of 
+         Just (AConLike (RealDataCon con)) -> return $ dataConSig con ^. _4
+         Just (AConLike (PatSynCon patSyn)) -> return $ patSynSig patSyn ^. _6
+         _ -> resultType
+typeExpr' (AST.RecUpdate e _) = typeExpr' e
+typeExpr' (AST.Enum from _ _) = mkListTy <$> typeExpr' from
+typeExpr' (AST.ParArrayEnum from _ _) = mkPArrTy <$> typeExpr' from
+typeExpr' (AST.ListComp e _) = mkListTy <$> typeExpr' e
+typeExpr' (AST.ParArrayComp e _) = mkPArrTy <$> typeExpr' e
+-- typeExpr' (AST.UTypeSig _ t) = -- TODO: evaluate type
+typeExpr' Hole = resultType
+typeExpr' _ = resultType
+
+literalType :: Literal -> Ghc GHC.Type
+literalType e = do usupp <- liftIO $ mkSplitUniqSupply 'z'
+                   evalStateT (literalType' e) (uniqsFromSupply usupp)
+
+literalType' :: Literal -> StateT [Unique] Ghc GHC.Type
+literalType' (StringLit {}) = return stringTy
+literalType' (CharLit {}) = return charTy
+literalType' (IntLit {}) = litType numClassName
+literalType' (FracLit {}) = litType fractionalClassName
+literalType' (PrimIntLit {}) = return $ intPrimTy
+literalType' (PrimWordLit {}) = return $ word32PrimTy
+literalType' (PrimFloatLit {}) = return $ floatX4PrimTy
+literalType' (PrimDoubleLit {}) = return $ doubleX2PrimTy
+literalType' (PrimCharLit {}) = return $ charPrimTy
+literalType' (PrimStringLit {}) = return $ addrPrimTy
+
+appTypeMatches :: [ClsInst] -> GHC.Type -> [GHC.Type] -> Maybe (TCvSubst, GHC.Type)
+appTypeMatches insts functionT argTs -- TODO: check instances
+  = let (funT, repackFun) = splitType functionT
+        (args, resT) = splitFunTys funT
+        argTypes = fst $ unzip $ map splitType argTs
+     in if length args >= length argTypes
+          then case tcUnifyTys (\_ -> BindMe) (take (length argTypes) args) argTypes of
+                 Just st -> let (t', check) = repackFun st insts (substTy st $ mkFunTys (drop (length argTypes) args) resT)
+                             in if check then Just (st, t')
+                                         else Nothing
+                 Nothing -> Nothing
+          else Nothing
+
+splitType' :: GHC.Type -> (GHC.Type, GHC.Type -> GHC.Type)
+splitType' t = case splitType t of (t', repack) -> (t', fst . repack emptyTCvSubst [])
+
+splitType :: GHC.Type -> (GHC.Type, TCvSubst -> [ClsInst] -> GHC.Type -> (GHC.Type, Bool))
+splitType typ =
+  let (foralls, typ') = splitForAllTys typ
+      (args, coreType) = splitFunTys typ'
+      (implicitArgs, realArgs) = partition isPredTy args
+      repack subst insts t = (mkInvForAllTys (filter (`elem` tvs) foralls) . mkFunTys keptConstraints $ t, check)
+        where
+          check = and $ map checkInst implicitArgs
+          checkInst t =
+            case splitTyConApp_maybe (substTy subst t) of
+              Just (tc, args) -> case tyConClass_maybe tc of 
+                                   Just cls -> case lookupInstEnv False instEnvs cls args of 
+                                                 ([],[],[]) -> False
+                                                 _          -> True
+                                   Nothing -> True
+              Nothing -> True
+          instEnvs = InstEnvs (extendInstEnvList emptyInstEnv insts) emptyInstEnv emptyModuleSet
+          keptConstraints = filter hasCommonTv implicitArgs
+          tvs = tyCoVarsOfTypeWellScoped t
+          hasCommonTv = not . null . intersect tvs . tyCoVarsOfTypeWellScoped
+   in (mkFunTys realArgs coreType, repack)
+
+resultType :: StateT [Unique] Ghc GHC.Type
+resultType = do 
+  name <- newName
+  let tv = mkTyVar name (mkTyConTy starKindTyCon)
+  return $ mkInvForAllTys [tv] (mkTyVarTy tv)
+
+litType :: GHC.Name -> StateT [Unique] Ghc GHC.Type
+litType constraint = do 
+  Just (ATyCon numTyCon) <- lift $ lookupName constraint
+  name <- newName
+  let tv = mkTyVar name (mkTyConTy starKindTyCon)
+  return $ mkInvForAllTys [tv] $ mkFunTy (mkTyConApp numTyCon [mkTyVarTy tv]) (mkTyVarTy tv)
+
+newName :: Monad m => StateT [Unique] m GHC.Name
+newName = do uniq <- gets head
+             modify tail
+             let occn  = mkOccName tvName "a"
+             return (mkInternalName uniq occn noSrcSpan)

@@ -0,0 +1,154 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
+
+module Language.Haskell.Tools.Refactor.Utils.TypeLookup where
+
+import qualified TyCoRep   as GHC (Type(..), TyThing(..))
+import qualified Kind      as GHC (isConstraintKind, typeKind)
+import qualified ConLike   as GHC (ConLike(..))
+import qualified DataCon   as GHC (dataConUserType, isVanillaDataCon)
+import qualified PatSyn    as GHC (patSynBuilder)
+import qualified Var       as GHC (varType)
+import qualified GHC       hiding (typeKind)
+import           GHC       (GhcMonad)
+
+import Language.Haskell.Tools.AST
+import Language.Haskell.Tools.Rewrite
+import Language.Haskell.Tools.Refactor.Utils.NameLookup
+import Language.Haskell.Tools.Refactor.Utils.Maybe
+
+
+hasConstraintKind :: GHC.Type -> Bool
+hasConstraintKind = GHC.isConstraintKind . GHC.typeKind
+
+
+-- | Looks up the Type of an entity with an Id of any locality.
+-- If the entity being scrutinised is a type variable, it fails.
+lookupTypeFromId :: (HasIdInfo' id, GhcMonad m) => id -> MaybeT m GHC.Type
+lookupTypeFromId idn
+  | GHC.isLocalId  . semanticsId $ idn = return . typeOrKindFromId $ idn
+  | GHC.isGlobalId . semanticsId $ idn = lookupTypeFromGlobalName idn
+  | otherwise = fail "Couldn't lookup name"
+
+-- | Looks up the Type or the Kind of an entity that has an Id.
+-- Note: In some cases we only get the Kind of the Id (e.g. for type constructors)
+typeOrKindFromId :: HasIdInfo' id => id -> GHC.Type
+typeOrKindFromId idn = GHC.varType . semanticsId $ idn
+
+-- | Extracts a Type from a TyThing when possible.
+typeFromTyThing :: GHC.TyThing -> Maybe GHC.Type
+typeFromTyThing (GHC.AnId     idn)  = Just . GHC.varType $ idn
+typeFromTyThing (GHC.ATyCon   tc)   = GHC.synTyConRhs_maybe tc
+typeFromTyThing (GHC.ACoAxiom _)    = fail "CoAxioms are not supported for type lookup"
+typeFromTyThing (GHC.AConLike con)  = handleCon con
+  where handleCon (GHC.RealDataCon dc) = Just . GHC.dataConUserType $ dc
+        handleCon (GHC.PatSynCon   pc) = do
+          (idn,_) <- GHC.patSynBuilder pc
+          return . GHC.varType $ idn
+
+-- | Looks up a GHC Type from a Haskell Tools Name (given the name is global)
+-- For an identifier, it returns its type.
+-- For a data constructor, it returns its type.
+-- For a pattern synonym, it returns its builder's type.
+-- For a type synonym constructor, it returns its right-hand side.
+-- For a coaxiom, it fails.
+lookupTypeFromGlobalName :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m GHC.Type
+lookupTypeFromGlobalName name = do
+  sname <- liftMaybe . semanticsName $ name
+  tt    <- MaybeT    . GHC.lookupName $ sname
+  liftMaybe . typeFromTyThing $ tt
+
+
+-- | Looks up the right-hand side (GHC representation)
+-- of a Haskell Tools Name corresponding to a type synonym
+lookupTypeSynRhs :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m GHC.Type
+lookupTypeSynRhs name = do
+  sname <- liftMaybe . semanticsName $ name
+  tt    <- MaybeT    . GHC.lookupName $ sname
+  tc    <- liftMaybe . tyconFromTyThing $ tt
+  liftMaybe . GHC.synTyConRhs_maybe $ tc
+
+-- NOTE: Returns Nothing if it is not a type synonym
+lookupSynDef :: GHC.TyThing -> Maybe GHC.TyCon
+lookupSynDef syn = do
+  tycon <- tyconFromTyThing syn
+  rhs   <- GHC.synTyConRhs_maybe tycon
+  tyconFromGHCType rhs
+
+tyconFromTyThing :: GHC.TyThing -> Maybe GHC.TyCon
+tyconFromTyThing (GHC.ATyCon tycon) = Just tycon
+tyconFromTyThing _ = Nothing
+
+-- won't bother
+tyconFromGHCType :: GHC.Type -> Maybe GHC.TyCon
+tyconFromGHCType (GHC.AppTy t1 _) = tyconFromGHCType t1
+tyconFromGHCType (GHC.TyConApp tycon _) = Just tycon
+tyconFromGHCType _ = Nothing
+
+
+-- NOTE: Returns false if the type is certainly not a newtype
+--       Returns true if it is a newtype or it could not have been looked up
+isNewtype :: GhcMonad m => Type -> m Bool
+isNewtype t = do
+  tycon <- runMaybeT . lookupType $ t
+  return $! maybe True isNewtypeTyCon tycon
+
+
+
+lookupType :: GhcMonad m => Type -> MaybeT m GHC.TyThing
+lookupType t = do
+  name  <- liftMaybe . nameFromType $ t
+  sname <- liftMaybe . semanticsName   $ name
+  MaybeT . GHC.lookupName $ sname
+
+-- | Looks up a GHC.Class from something that has a type class constructor in it
+-- Fails if the argument does not contain a class type constructor
+lookupClassWith :: GhcMonad m => (a -> MaybeT m GHC.Name) -> a -> MaybeT m GHC.Class
+lookupClassWith getName x = do
+  sname   <- getName x
+  tything <- MaybeT . GHC.lookupName $ sname
+  case tything of
+    GHC.ATyCon tc | GHC.isClassTyCon tc -> liftMaybe . GHC.tyConClass_maybe $ tc
+    _ -> fail "TypeLookup.lookupClassWith: Argument does not contain a class type constructor"
+
+lookupClassFromInstance :: GhcMonad m => InstanceHead -> MaybeT m GHC.Class
+lookupClassFromInstance = lookupClassWith instHeadSemName
+
+lookupClassFromDeclHead :: GhcMonad m => DeclHead -> MaybeT m GHC.Class
+lookupClassFromDeclHead = lookupClassWith declHeadSemName
+
+-- | Looks up the right-hand side (GHC representation)
+-- of a Haskell Tools Type corresponding to a type synonym
+semanticsTypeSynRhs :: GhcMonad m => Type -> MaybeT m GHC.Type
+semanticsTypeSynRhs ty = (liftMaybe . nameFromType $ ty) >>= lookupTypeSynRhs
+
+-- | Converts a global Haskell Tools type to a GHC type
+semanticsType :: GhcMonad m => Type -> MaybeT m GHC.Type
+semanticsType ty = (liftMaybe . nameFromType $ ty) >>= lookupTypeFromGlobalName
+
+-- | Extracts the name of a type
+-- In case of a type application, it finds the type being applied
+nameFromType :: Type -> Maybe Name
+nameFromType (TypeApp f _)    = nameFromType f
+nameFromType (ParenType x)    = nameFromType x
+nameFromType (KindedType t _) = nameFromType t
+nameFromType (BangType t)     = nameFromType t
+nameFromType (LazyType t)     = nameFromType t
+nameFromType (UnpackType t)   = nameFromType t
+nameFromType (NoUnpackType t) = nameFromType t
+nameFromType (VarType x)      = Just x
+nameFromType _                = Nothing
+
+isNewtypeTyCon :: GHC.TyThing -> Bool
+isNewtypeTyCon (GHC.ATyCon tycon) = GHC.isNewTyCon tycon
+isNewtypeTyCon _ = False
+
+-- | Decides whether a given name is a standard Haskell98 data constructor.
+-- Fails if not given a proper name.
+isVanillaDataConNameM :: (HasNameInfo' n, GhcMonad m) => n -> MaybeT m Bool
+isVanillaDataConNameM name = do
+  sname <- liftMaybe . semanticsName  $ name
+  tt    <- MaybeT    . GHC.lookupName $ sname
+  dc    <- liftMaybe . extractDataCon $ tt
+  return . GHC.isVanillaDataCon $ dc
+  where extractDataCon (GHC.AConLike (GHC.RealDataCon dc)) = Just dc
+        extractDataCon  _                                  = Nothing

@@ -0,0 +1,8 @@+{-# LANGUAGE CPP #-}
+module CPP.ConditionalCode where
+
+#if __GLASGOW_HASKELL__ >= 800
+version = "GHC 8"
+#else
+version = "not GHC 8"
+#endif

@@ -0,0 +1,2 @@+{-# LANGUAGE CPP #-}
+module CPP.JustEnabled where

@@ -0,0 +1,10 @@+module CommentHandling.BlockComments where
+
+{-| 1 -}
+{- 2 -}
+import Control.Monad {- 3 -}
+{-^ 4 -}
+{-| 5 -}
+{- 6 -}
+import Control.Monad as Monad {- 7 -}
+{-^ 8 -}

@@ -0,0 +1,10 @@+module CommentHandling.CommentTypes where
+
+-- | 1
+-- 2
+import Control.Monad -- 3
+-- ^ 4
+-- | 5
+-- 6
+import Control.Monad as Monad -- 7
+-- ^ 8

@@ -0,0 +1,6 @@+module CommentHandling.Crosslinking where
+
+import Control.Monad
+-- | forward
+-- ^ back
+import Control.Monad as Monad

@@ -0,0 +1,6 @@+module CommentHandling.FunctionArgs where
+
+f :: Int -- something
+  -> {-| result -} Int
+  -> Int  -- ^ other thing
+f = undefined

@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Language.Preprocessor.Cpphs
+-- Copyright   :  2000-2006 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- Include the interface that is exported
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs
+  ( runCpphs, runCpphsPass1, runCpphsPass2, runCpphsReturningSymTab
+  , cppIfdef, tokenise, WordStyle(..)
+  , macroPass, macroPassReturningSymTab
+  , CpphsOptions(..), BoolOptions(..)
+  , parseOptions, defaultCpphsOptions, defaultBoolOptions
+  , module Language.Preprocessor.Cpphs.Position
+  ) where
+
+import Language.Preprocessor.Cpphs.CppIfdef(cppIfdef)
+import Language.Preprocessor.Cpphs.MacroPass(macroPass
+                                            ,macroPassReturningSymTab)
+import Language.Preprocessor.Cpphs.RunCpphs(runCpphs
+                                           ,runCpphsPass1
+                                           ,runCpphsPass2
+                                           ,runCpphsReturningSymTab)
+import Language.Preprocessor.Cpphs.Options
+       (CpphsOptions(..), BoolOptions(..), parseOptions
+       ,defaultCpphsOptions,defaultBoolOptions)
+import Language.Preprocessor.Cpphs.Position
+import Language.Preprocessor.Cpphs.Tokenise

@@ -0,0 +1,416 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  CppIfdef
+-- Copyright   :  1999-2004 Malcolm Wallace
+-- Licence     :  LGPL
+-- 
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+
+-- Perform a cpp.first-pass, gathering \#define's and evaluating \#ifdef's.
+-- and \#include's.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.CppIfdef
+  ( cppIfdef    -- :: FilePath -> [(String,String)] -> [String] -> Options
+                --      -> String -> IO [(Posn,String)]
+  ) where
+
+
+import Text.Parse
+import Language.Preprocessor.Cpphs.SymTab
+import Language.Preprocessor.Cpphs.Position  (Posn,newfile,newline,newlines
+                                             ,cppline,cpp2hask,newpos)
+import Language.Preprocessor.Cpphs.ReadFirst (readFirst)
+import Language.Preprocessor.Cpphs.Tokenise  (linesCpp,reslash)
+import Language.Preprocessor.Cpphs.Options   (BoolOptions(..))
+import Language.Preprocessor.Cpphs.HashDefine(HashDefine(..),parseHashDefine
+                                             ,expandMacro)
+import Language.Preprocessor.Cpphs.MacroPass (preDefine,defineMacro)
+import Data.Char        (isDigit,isSpace,isAlphaNum)
+import Data.List        (intercalate,isPrefixOf)
+import Numeric          (readHex,readOct,readDec)
+import System.IO.Unsafe (unsafeInterleaveIO)
+import System.IO        (hPutStrLn,stderr)
+import Control.Monad    (when)
+
+-- | Run a first pass of cpp, evaluating \#ifdef's and processing \#include's,
+--   whilst taking account of \#define's and \#undef's as we encounter them.
+cppIfdef :: FilePath            -- ^ File for error reports
+        -> [(String,String)]    -- ^ Pre-defined symbols and their values
+        -> [String]             -- ^ Search path for \#includes
+        -> BoolOptions          -- ^ Options controlling output style
+        -> String               -- ^ The input file content
+        -> IO [(Posn,String)]   -- ^ The file after processing (in lines)
+cppIfdef fp syms search options =
+    cpp posn defs search options (Keep []) . initial . linesCpp
+  where
+    posn = newfile fp
+    defs = preDefine options syms
+    initial = if literate options then id else (cppline posn:)
+-- Previous versions had a very simple symbol table  mapping strings
+-- to strings.  Now the #ifdef pass uses a more elaborate table, in
+-- particular to deal with parameterised macros in conditionals.
+
+
+-- | Internal state for whether lines are being kept or dropped.
+--   In @Drop n b ps@, @n@ is the depth of nesting, @b@ is whether
+--   we have already succeeded in keeping some lines in a chain of
+--   @elif@'s, and @ps@ is the stack of positions of open @#if@ contexts,
+--   used for error messages in case EOF is reached too soon.
+data KeepState = Keep [Posn] | Drop Int Bool [Posn]
+
+-- | Return just the list of lines that the real cpp would decide to keep.
+cpp :: Posn -> SymTab HashDefine -> [String] -> BoolOptions -> KeepState
+       -> [String] -> IO [(Posn,String)]
+
+cpp _ _ _ _ (Keep ps) [] | not (null ps) = do
+    hPutStrLn stderr $ "Unmatched #if: positions of open context are:\n"++
+                       unlines (map show ps)
+    return []
+cpp _ _ _ _ _ [] = return []
+
+cpp p syms path options (Keep ps) (l@('#':x):xs) =
+    let ws = words x
+        cmd = if null ws then "" else head ws
+        line = tail ws
+        sym  = head (tail ws)
+        rest = tail (tail ws)
+        def = defineMacro options (sym++" "++ maybe "1" id (un rest))
+        un v = if null v then Nothing else Just (unwords v)
+        keepIf b = if b then Keep (p:ps) else Drop 1 False (p:ps)
+        skipn syms' retain ud xs' =
+            let n = 1 + length (filter (=='\n') l) in
+            (if macros options && retain then emitOne  (p,reslash l)
+                                         else emitMany (replicate n (p,""))) $
+            cpp (newlines n p) syms' path options ud xs'
+    in case cmd of
+        "define" -> skipn (insertST def syms) True (Keep ps) xs
+        "undef"  -> skipn (deleteST sym syms) True (Keep ps) xs
+        "ifndef" -> skipn syms False (keepIf (not (definedST sym syms))) xs
+        "ifdef"  -> skipn syms False (keepIf      (definedST sym syms)) xs
+        "if"     -> do b <- gatherDefined p syms (unwords line)
+                       skipn syms False (keepIf b) xs
+        "else"   -> skipn syms False (Drop 1 False ps) xs
+        "elif"   -> skipn syms False (Drop 1 True ps) xs
+        "endif"  | null ps ->
+                    do hPutStrLn stderr $ "Unmatched #endif at "++show p
+                       return []
+        "endif"  -> skipn syms False (Keep (tail ps)) xs
+        "pragma" -> skipn syms True  (Keep ps) xs
+        ('!':_)  -> skipn syms False (Keep ps) xs       -- \#!runhs scripts
+        "include"-> do (inc,content) <- readFirst (file syms (unwords line))
+                                                  p path
+                                                  (warnings options)
+                       cpp p syms path options (Keep ps)
+                             (("#line 1 "++show inc): linesCpp content
+                                                    ++ cppline (newline p): xs)
+        "warning"-> if warnings options then
+                      do hPutStrLn stderr (l++"\nin "++show p)
+                         skipn syms False (Keep ps) xs
+                    else skipn syms False (Keep ps) xs
+        "error"  -> error (l++"\nin "++show p)
+        "line"   | all isDigit sym
+                 -> (if locations options && hashline options then emitOne (p,l)
+                     else if locations options then emitOne (p,cpp2hask l)
+                     else id) $
+                    cpp (newpos (read sym) (un rest) p)
+                        syms path options (Keep ps) xs
+        n | all isDigit n && not (null n)
+                 -> (if locations options && hashline options then emitOne (p,l)
+                     else if locations options then emitOne (p,cpp2hask l)
+                     else id) $
+                    cpp (newpos (read n) (un (tail ws)) p)
+                        syms path options (Keep ps) xs
+          | otherwise
+                 -> do when (warnings options) $
+                           hPutStrLn stderr ("Warning: unknown directive #"++n
+                                             ++"\nin "++show p)
+                       emitOne (p,l) $
+                               cpp (newline p) syms path options (Keep ps) xs
+
+cpp p syms path options (Drop n b ps) (('#':x):xs) =
+    let ws = words x
+        cmd = if null ws then "" else head ws
+        delse    | n==1 && b = Drop 1 b ps
+                 | n==1      = Keep ps
+                 | otherwise = Drop n b ps
+        dend     | n==1      = Keep (tail ps)
+                 | otherwise = Drop (n-1) b (tail ps)
+        delif v  | n==1 && not b && v
+                             = Keep ps
+                 | otherwise = Drop n b ps
+        skipn ud xs' =
+                 let n' = 1 + length (filter (=='\n') x) in
+                 emitMany (replicate n' (p,"")) $
+                    cpp (newlines n' p) syms path options ud xs'
+    in
+    if      cmd == "ifndef" ||
+            cmd == "if"     ||
+            cmd == "ifdef" then    skipn (Drop (n+1) b (p:ps)) xs
+    else if cmd == "elif"  then do v <- gatherDefined p syms (unwords (tail ws))
+                                   skipn (delif v) xs
+    else if cmd == "else"  then    skipn  delse xs
+    else if cmd == "endif" then
+            if null ps then do hPutStrLn stderr $ "Unmatched #endif at "++show p
+                               return []
+                       else skipn  dend  xs
+    else skipn (Drop n b ps) xs
+        -- define, undef, include, error, warning, pragma, line
+
+cpp p syms path options (Keep ps) (x:xs) =
+    let p' = newline p in seq p' $
+    emitOne (p,x)  $  cpp p' syms path options (Keep ps) xs
+cpp p syms path options d@(Drop _ _ _) (_:xs) =
+    let p' = newline p in seq p' $
+    emitOne (p,"") $  cpp p' syms path options d xs
+
+
+-- | Auxiliary IO functions
+emitOne  ::  a  -> IO [a] -> IO [a]
+emitMany :: [a] -> IO [a] -> IO [a]
+emitOne  x  io = do ys <- unsafeInterleaveIO io
+                    return (x:ys)
+emitMany xs io = do ys <- unsafeInterleaveIO io
+                    return (xs++ys)
+
+
+----
+gatherDefined :: Posn -> SymTab HashDefine -> String -> IO Bool
+gatherDefined p st inp =
+  case runParser (preExpand st) inp of
+    (Left msg, _) -> error ("Cannot expand #if directive in file "++show p
+                           ++":\n    "++msg)
+    (Right s, xs) -> do
+--      hPutStrLn stderr $ "Expanded #if at "++show p++" is:\n  "++s
+        when (any (not . isSpace) xs) $
+             hPutStrLn stderr ("Warning: trailing characters after #if"
+                              ++" macro expansion in file "++show p++": "++xs)
+
+        case runParser parseBoolExp s of
+          (Left msg, _) -> error ("Cannot parse #if directive in file "++show p
+                                 ++":\n    "++msg)
+          (Right b, xs) -> do when (any (not . isSpace) xs && notComment xs) $
+                                   hPutStrLn stderr
+                                     ("Warning: trailing characters after #if"
+                                      ++" directive in file "++show p++": "++xs)
+                              return b
+
+notComment = not . ("//"`isPrefixOf`) . dropWhile isSpace
+
+
+-- | The preprocessor must expand all macros (recursively) before evaluating
+--   the conditional.
+preExpand :: SymTab HashDefine -> TextParser String
+preExpand st =
+  do  eof
+      return ""
+  <|>
+  do  a <- many1 (satisfy notIdent)
+      commit $ pure (a++) `apply` preExpand st
+  <|>
+  do  b <- expandSymOrCall st
+      commit $ pure (b++) `apply` preExpand st
+
+-- | Expansion of symbols.
+expandSymOrCall :: SymTab HashDefine -> TextParser String
+expandSymOrCall st =
+  do sym <- parseSym
+     if sym=="defined" then do arg <- skip parseSym; convert sym [arg]
+                            <|>
+                            do arg <- skip $ parenthesis (do x <- skip parseSym;
+                                                             skip (return x))
+                               convert sym [arg]
+                            <|> convert sym []
+      else
+      ( do  args <- parenthesis (commit $ fragment `sepBy` skip (isWord ","))
+            args' <- flip mapM args $ \arg->
+                         case runParser (preExpand st) arg of
+                             (Left msg, _) -> fail msg
+                             (Right s, _)  -> return s
+            convert sym args'
+        <|> convert sym []
+      )
+  where
+    fragment = many1 (satisfy (`notElem`",)"))
+    convert "defined" [arg] =
+      case lookupST arg st of
+        Nothing | all isDigit arg    -> return arg 
+        Nothing                      -> return "0"
+        Just (a@AntiDefined{})       -> return "0"
+        Just (a@SymbolReplacement{}) -> return "1"
+        Just (a@MacroExpansion{})    -> return "1"
+    convert sym args =
+      case lookupST sym st of
+        Nothing  -> if null args then return sym
+                    else return "0"
+                 -- else fail (disp sym args++" is not a defined macro")
+        Just (a@SymbolReplacement{}) -> do reparse (replacement a)
+                                           return ""
+        Just (a@MacroExpansion{})    -> do reparse (expandMacro a args False)
+                                           return ""
+        Just (a@AntiDefined{})       ->
+                    if null args then return sym
+                    else return "0"
+                 -- else fail (disp sym args++" explicitly undefined with -U")
+    disp sym args = let len = length args
+                        chars = map (:[]) ['a'..'z']
+                    in sym ++ if null args then ""
+                              else "("++intercalate "," (take len chars)++")"
+
+parseBoolExp :: TextParser Bool
+parseBoolExp =
+  do  a <- parseExp1
+      bs <- many (do skip (isWord "||")
+                     commit $ skip parseBoolExp)
+      return $ foldr (||) a bs
+
+parseExp1 :: TextParser Bool
+parseExp1 =
+  do  a <- parseExp0
+      bs <- many (do skip (isWord "&&")
+                     commit $ skip parseExp1)
+      return $ foldr (&&) a bs
+
+parseExp0 :: TextParser Bool
+parseExp0 =
+  do  skip (isWord "!")
+      a <- commit $ parseExp0
+      return (not a)
+  <|>
+  do  val1 <- parseArithExp1
+      op   <- parseCmpOp
+      val2 <- parseArithExp1
+      return (val1 `op` val2)
+  <|>
+  do  sym <- parseArithExp1
+      case sym of
+        0 -> return False
+        _ -> return True
+  <|>
+  do  parenthesis (commit parseBoolExp)
+
+parseArithExp1 :: TextParser Integer
+parseArithExp1 =
+  do  val1 <- parseArithExp0
+      ( do op   <- parseArithOp1
+           val2 <- parseArithExp1
+           return (val1 `op` val2)
+        <|> return val1 )
+  <|>
+  do  parenthesis parseArithExp1
+
+parseArithExp0 :: TextParser Integer
+parseArithExp0 =
+  do  val1 <- parseNumber
+      ( do op   <- parseArithOp0
+           val2 <- parseArithExp0
+           return (val1 `op` val2)
+        <|> return val1 )
+  <|>
+  do  parenthesis parseArithExp0
+
+parseNumber :: TextParser Integer
+parseNumber = fmap safeRead $ skip parseSym
+  where
+    safeRead s =
+      case s of
+        '0':'x':s' -> number readHex s'
+        '0':'o':s' -> number readOct s'
+        _          -> number readDec s
+    number rd s =
+      case rd s of
+        []        -> 0 :: Integer
+        ((n,_):_) -> n :: Integer
+
+parseCmpOp :: TextParser (Integer -> Integer -> Bool)
+parseCmpOp =
+  do  skip (isWord ">=")
+      return (>=)
+  <|>
+  do  skip (isWord ">")
+      return (>)
+  <|>
+  do  skip (isWord "<=")
+      return (<=)
+  <|>
+  do  skip (isWord "<")
+      return (<)
+  <|>
+  do  skip (isWord "==")
+      return (==)
+  <|>
+  do  skip (isWord "!=")
+      return (/=)
+
+parseArithOp1 :: TextParser (Integer -> Integer -> Integer)
+parseArithOp1 =
+  do  skip (isWord "+")
+      return (+)
+  <|>
+  do  skip (isWord "-")
+      return (-)
+
+parseArithOp0 :: TextParser (Integer -> Integer -> Integer)
+parseArithOp0 =
+  do  skip (isWord "*")
+      return (*)
+  <|>
+  do  skip (isWord "/")
+      return (div)
+  <|>
+  do  skip (isWord "%")
+      return (rem)
+
+-- | Return the expansion of the symbol (if there is one).
+parseSymOrCall :: SymTab HashDefine -> TextParser String
+parseSymOrCall st =
+  do  sym <- skip parseSym
+      args <- parenthesis (commit $ parseSymOrCall st `sepBy` skip (isWord ","))
+      return $ convert sym args
+  <|>
+  do  sym <- skip parseSym
+      return $ convert sym []
+  where
+    convert sym args =
+      case lookupST sym st of
+        Nothing  -> sym
+        Just (a@SymbolReplacement{}) -> recursivelyExpand st (replacement a)
+        Just (a@MacroExpansion{})    -> recursivelyExpand st (expandMacro a args False)
+        Just (a@AntiDefined{})       -> name a
+
+recursivelyExpand :: SymTab HashDefine -> String -> String
+recursivelyExpand st inp =
+  case runParser (parseSymOrCall st) inp of
+    (Left msg, _) -> inp
+    (Right s,  _) -> s
+
+parseSym :: TextParser String
+parseSym = many1 (satisfy (\c-> isAlphaNum c || c`elem`"'`_"))
+           `onFail`
+           do xs <- allAsString
+              fail $ "Expected an identifier, got \""++xs++"\""
+
+notIdent :: Char -> Bool
+notIdent c = not (isAlphaNum c || c`elem`"'`_")
+
+skip :: TextParser a -> TextParser a
+skip p = many (satisfy isSpace) >> p
+
+-- | The standard "parens" parser does not work for us here.  Define our own.
+parenthesis :: TextParser a -> TextParser a
+parenthesis p = do isWord "("
+                   x <- p
+                   isWord ")"
+                   return x
+
+-- | Determine filename in \#include
+file :: SymTab HashDefine -> String -> String
+file st name =
+    case name of
+      ('"':ns) -> init ns
+      ('<':ns) -> init ns
+      _ -> let ex = recursivelyExpand st name in
+           if ex == name then name else file st ex
+

@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  HashDefine
+-- Copyright   :  2004 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- What structures are declared in a \#define.
+-----------------------------------------------------------------------------
+ 
+module Language.Preprocessor.Cpphs.HashDefine
+  ( HashDefine(..)
+  , ArgOrText(..)
+  , expandMacro
+  , parseHashDefine
+  , simplifyHashDefines
+  ) where
+
+import Data.Char (isSpace)
+import Data.List (intercalate)
+
+data HashDefine
+        = LineDrop
+                { name :: String }
+        | Pragma
+                { name :: String }
+        | AntiDefined
+                { name          :: String
+                , linebreaks    :: Int
+                }
+        | SymbolReplacement
+                { name          :: String
+                , replacement   :: String
+                , linebreaks    :: Int
+                }
+        | MacroExpansion
+                { name          :: String
+                , arguments     :: [String]
+                , expansion     :: [(ArgOrText,String)]
+                , linebreaks    :: Int
+                }
+    deriving (Eq,Show)
+
+-- | 'smart' constructor to avoid warnings from ghc (undefined fields)
+symbolReplacement :: HashDefine
+symbolReplacement =
+    SymbolReplacement
+         { name=undefined, replacement=undefined, linebreaks=undefined }
+
+-- | Macro expansion text is divided into sections, each of which is classified
+--   as one of three kinds: a formal argument (Arg), plain text (Text),
+--   or a stringised formal argument (Str).
+data ArgOrText = Arg | Text | Str deriving (Eq,Show)
+
+-- | Expand an instance of a macro.
+--   Precondition: got a match on the macro name.
+expandMacro :: HashDefine -> [String] -> Bool -> String
+expandMacro macro parameters layout =
+    let env = zip (arguments macro) parameters
+        replace (Arg,s)  = maybe ("")      id (lookup s env)
+        replace (Str,s)  = maybe (str "") str (lookup s env)
+        replace (Text,s) = if layout then s else filter (/='\n') s
+        str s = '"':s++"\""
+        checkArity | length (arguments macro) == 1 && length parameters <= 1
+                   || length (arguments macro) == length parameters = id
+                   | otherwise = error ("macro "++name macro++" expected "++
+                                        show (length (arguments macro))++
+                                        " arguments, but was given "++
+                                        show (length parameters))
+    in
+    checkArity $ concatMap replace (expansion macro)
+
+-- | Parse a \#define, or \#undef, ignoring other \# directives
+parseHashDefine :: Bool -> [String] -> Maybe HashDefine
+parseHashDefine ansi def = (command . skip) def
+  where
+    skip xss@(x:xs) | all isSpace x = skip xs
+                    | otherwise     = xss
+    skip    []      = []
+    command ("line":xs)   = Just (LineDrop ("#line"++concat xs))
+    command ("pragma":xs) = Just (Pragma ("#pragma"++concat xs))
+    command ("define":xs) = Just (((define . skip) xs) { linebreaks=count def })
+    command ("undef":xs)  = Just (((undef  . skip) xs))
+    command _             = Nothing
+    undef  (sym:_)   = AntiDefined { name=sym, linebreaks=0 }
+    define (sym:xs)  = case {-skip-} xs of
+                           ("(":ys) -> (macroHead sym [] . skip) ys
+                           ys   -> symbolReplacement
+                                     { name=sym
+                                     , replacement = concatMap snd
+                                             (classifyRhs [] (chop (skip ys))) }
+    macroHead sym args (",":xs) = (macroHead sym args . skip) xs
+    macroHead sym args (")":xs) = MacroExpansion
+                                    { name =sym , arguments = reverse args
+                                    , expansion = classifyRhs args (skip xs)
+                                    , linebreaks = undefined }
+    macroHead sym args (var:xs) = (macroHead sym (var:args) . skip) xs
+    macroHead sym args []       = error ("incomplete macro definition:\n"
+                                        ++"  #define "++sym++"("
+                                        ++intercalate "," args)
+    classifyRhs args ("#":x:xs)
+                          | ansi &&
+                            x `elem` args    = (Str,x): classifyRhs args xs
+    classifyRhs args ("##":xs)
+                          | ansi             = classifyRhs args xs
+    classifyRhs args (s:"##":s':xs)
+                          | ansi && all isSpace s && all isSpace s'
+                                             = classifyRhs args xs
+    classifyRhs args (word:xs)
+                          | word `elem` args = (Arg,word): classifyRhs args xs
+                          | otherwise        = (Text,word): classifyRhs args xs
+    classifyRhs _    []                      = []
+    count = length . filter (=='\n') . concat
+    chop  = reverse . dropWhile (all isSpace) . reverse
+
+-- | Pretty-print hash defines to a simpler format, as key-value pairs.
+simplifyHashDefines :: [HashDefine] -> [(String,String)]
+simplifyHashDefines = concatMap simp
+  where
+    simp hd@LineDrop{}    = []
+    simp hd@Pragma{}      = []
+    simp hd@AntiDefined{} = []
+    simp hd@SymbolReplacement{} = [(name hd, replacement hd)]
+    simp hd@MacroExpansion{}    = [(name hd++"("++intercalate "," (arguments hd)
+                                           ++")"
+                                   ,concatMap snd (expansion hd))]

@@ -0,0 +1,184 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  MacroPass
+-- Copyright   :  2004 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- Perform a cpp.second-pass, accumulating \#define's and \#undef's,
+-- whilst doing symbol replacement and macro expansion.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.MacroPass
+  ( macroPass
+  , preDefine
+  , defineMacro
+  , macroPassReturningSymTab
+  ) where
+
+import Language.Preprocessor.Cpphs.HashDefine (HashDefine(..), expandMacro
+                                              , simplifyHashDefines)
+import Language.Preprocessor.Cpphs.Tokenise   (tokenise, WordStyle(..)
+                                              , parseMacroCall)
+import Language.Preprocessor.Cpphs.SymTab     (SymTab, lookupST, insertST
+                                              , emptyST, flattenST)
+import Language.Preprocessor.Cpphs.Position   (Posn, newfile, filename, lineno)
+import Language.Preprocessor.Cpphs.Options    (BoolOptions(..))
+import System.IO.Unsafe (unsafeInterleaveIO)
+import Control.Monad    ((=<<))
+import System.Time       (getClockTime, toCalendarTime, formatCalendarTime)
+import System.Locale     (defaultTimeLocale)
+
+noPos :: Posn
+noPos = newfile "preDefined"
+
+-- | Walk through the document, replacing calls of macros with the expanded RHS.
+macroPass :: [(String,String)]  -- ^ Pre-defined symbols and their values
+          -> BoolOptions        -- ^ Options that alter processing style
+          -> [(Posn,String)]    -- ^ The input file content
+          -> IO String          -- ^ The file after processing
+macroPass syms options =
+    fmap (safetail              -- to remove extra "\n" inserted below
+         . concat
+         . onlyRights)
+    . macroProcess (pragma options) (layout options) (lang options)
+                   (preDefine options syms)
+    . tokenise (stripEol options) (stripC89 options)
+               (ansi options) (lang options)
+    . ((noPos,""):)     -- ensure recognition of "\n#" at start of file
+  where
+    safetail [] = []
+    safetail (_:xs) = xs
+
+-- | auxiliary
+onlyRights :: [Either a b] -> [b]
+onlyRights = concatMap (\x->case x of Right t-> [t]; Left _-> [];)
+
+-- | Walk through the document, replacing calls of macros with the expanded RHS.
+--   Additionally returns the active symbol table after processing.
+macroPassReturningSymTab
+          :: [(String,String)]  -- ^ Pre-defined symbols and their values
+          -> BoolOptions        -- ^ Options that alter processing style
+          -> [(Posn,String)]    -- ^ The input file content
+          -> IO (String,[(String,String)])
+                                -- ^ The file and symbol table after processing
+macroPassReturningSymTab syms options =
+    fmap (mapFst (safetail              -- to remove extra "\n" inserted below
+                 . concat)
+         . walk)
+    . macroProcess (pragma options) (layout options) (lang options)
+                   (preDefine options syms)
+    . tokenise (stripEol options) (stripC89 options)
+               (ansi options) (lang options)
+    . ((noPos,""):)     -- ensure recognition of "\n#" at start of file
+  where
+    safetail [] = []
+    safetail (_:xs) = xs
+    walk (Right x: rest) = let (xs,   foo) = walk rest
+                           in  (x:xs, foo)
+    walk (Left  x: [])   =     ( [] , simplifyHashDefines (flattenST x) )
+    walk (Left  x: rest) = walk rest
+    mapFst f (a,b) = (f a, b)
+
+
+-- | Turn command-line definitions (from @-D@) into 'HashDefine's.
+preDefine :: BoolOptions -> [(String,String)] -> SymTab HashDefine
+preDefine options defines =
+    foldr (insertST . defineMacro options . (\ (s,d)-> s++" "++d))
+          emptyST defines
+
+-- | Turn a string representing a macro definition into a 'HashDefine'.
+defineMacro :: BoolOptions -> String -> (String,HashDefine)
+defineMacro opts s =
+    let (Cmd (Just hd):_) = tokenise True True (ansi opts) (lang opts)
+                                     [(noPos,"\n#define "++s++"\n")]
+    in (name hd, hd)
+
+
+-- | Trundle through the document, one word at a time, using the WordStyle
+--   classification introduced by 'tokenise' to decide whether to expand a
+--   word or macro.  Encountering a \#define or \#undef causes that symbol to
+--   be overwritten in the symbol table.  Any other remaining cpp directives
+--   are discarded and replaced with blanks, except for \#line markers.
+--   All valid identifiers are checked for the presence of a definition
+--   of that name in the symbol table, and if so, expanded appropriately.
+--   (Bool arguments are: keep pragmas?  retain layout?  haskell language?)
+--   The result lazily intersperses output text with symbol tables.  Lines
+--   are emitted as they are encountered.  A symbol table is emitted after
+--   each change to the defined symbols, and always at the end of processing.
+macroProcess :: Bool -> Bool -> Bool -> SymTab HashDefine -> [WordStyle]
+             -> IO [Either (SymTab HashDefine) String]
+macroProcess _ _ _ st        []          = return [Left st]
+macroProcess p y l st (Other x: ws)      = emit x    $ macroProcess p y l st ws
+macroProcess p y l st (Cmd Nothing: ws)  = emit "\n" $ macroProcess p y l st ws
+macroProcess p y l st (Cmd (Just (LineDrop x)): ws)
+                                         = emit "\n" $
+                                           emit x    $ macroProcess p y l st ws
+macroProcess pragma y l st (Cmd (Just (Pragma x)): ws)
+               | pragma    = emit "\n" $ emit x $ macroProcess pragma y l st ws
+               | otherwise = emit "\n" $          macroProcess pragma y l st ws
+macroProcess p layout lang st (Cmd (Just hd): ws) =
+    let n = 1 + linebreaks hd
+        newST = insertST (name hd, hd) st
+    in
+    emit (replicate n '\n') $
+    emitSymTab newST $
+    macroProcess p layout lang newST ws
+macroProcess pr layout lang st (Ident p x: ws) =
+    case x of
+      "__FILE__" -> emit (show (filename p))$ macroProcess pr layout lang st ws
+      "__LINE__" -> emit (show (lineno p))  $ macroProcess pr layout lang st ws
+      "__DATE__" -> do w <- return .
+                            formatCalendarTime defaultTimeLocale "\"%d %b %Y\""
+                            =<< toCalendarTime =<< getClockTime
+                       emit w $ macroProcess pr layout lang st ws
+      "__TIME__" -> do w <- return .
+                            formatCalendarTime defaultTimeLocale "\"%H:%M:%S\""
+                            =<< toCalendarTime =<< getClockTime
+                       emit w $ macroProcess pr layout lang st ws
+      _ ->
+        case lookupST x st of
+            Nothing -> emit x $ macroProcess pr layout lang st ws
+            Just hd ->
+                case hd of
+                    AntiDefined {name=n} -> emit n $
+                                            macroProcess pr layout lang st ws
+                    SymbolReplacement {replacement=r} ->
+                        let r' = if layout then r else filter (/='\n') r in
+                        -- one-level expansion only:
+                        -- emit r' $ macroProcess layout st ws
+                        -- multi-level expansion:
+                        macroProcess pr layout lang st
+                                     (tokenise True True False lang [(p,r')]
+                                      ++ ws)
+                    MacroExpansion {} ->
+                        case parseMacroCall p ws of
+                            Nothing -> emit x $
+                                       macroProcess pr layout lang st ws
+                            Just (args,ws') ->
+                                if length args /= length (arguments hd) then
+                                     emit x $ macroProcess pr layout lang st ws
+                                else do args' <- mapM (fmap (concat.onlyRights)
+                                                       . macroProcess pr layout
+                                                                        lang st)
+                                                      args
+                                        -- one-level expansion only:
+                                        -- emit (expandMacro hd args' layout) $
+                                        --         macroProcess layout st ws'
+                                        -- multi-level expansion:
+                                        macroProcess pr layout lang st
+                                            (tokenise True True False lang
+                                               [(p,expandMacro hd args' layout)]
+                                            ++ ws')
+
+-- | Useful helper function.
+emit :: a -> IO [Either b a] -> IO [Either b a]
+emit x io = do xs <- unsafeInterleaveIO io
+               return (Right x:xs)
+-- | Useful helper function.
+emitSymTab :: b -> IO [Either b a] -> IO [Either b a]
+emitSymTab x io = do xs <- unsafeInterleaveIO io
+                     return (Left x:xs)

@@ -0,0 +1,156 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Options
+-- Copyright   :  2006 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- This module deals with Cpphs options and parsing them
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.Options
+  ( CpphsOptions(..)
+  , BoolOptions(..)
+  , parseOptions
+  , defaultCpphsOptions
+  , defaultBoolOptions
+  , trailing
+  ) where
+
+import Data.Maybe
+import Data.List (isPrefixOf)
+
+-- | Cpphs options structure.
+data CpphsOptions = CpphsOptions 
+    { infiles   :: [FilePath]
+    , outfiles  :: [FilePath]
+    , defines   :: [(String,String)]
+    , includes  :: [String]
+    , preInclude:: [FilePath]   -- ^ Files to \#include before anything else
+    , boolopts  :: BoolOptions
+    } deriving (Show)
+
+-- | Default options.
+defaultCpphsOptions :: CpphsOptions
+defaultCpphsOptions = CpphsOptions { infiles = [], outfiles = []
+                                   , defines = [], includes = []
+                                   , preInclude = []
+                                   , boolopts = defaultBoolOptions }
+
+-- | Options representable as Booleans.
+data BoolOptions = BoolOptions
+    { macros    :: Bool  -- ^ Leave \#define and \#undef in output of ifdef?
+    , locations :: Bool  -- ^ Place \#line droppings in output?
+    , hashline  :: Bool  -- ^ Write \#line or {-\# LINE \#-} ?
+    , pragma    :: Bool  -- ^ Keep \#pragma in final output?
+    , stripEol  :: Bool  -- ^ Remove C eol (\/\/) comments everywhere?
+    , stripC89  :: Bool  -- ^ Remove C inline (\/**\/) comments everywhere?
+    , lang      :: Bool  -- ^ Lex input as Haskell code?
+    , ansi      :: Bool  -- ^ Permit stringise \# and catenate \#\# operators?
+    , layout    :: Bool  -- ^ Retain newlines in macro expansions?
+    , literate  :: Bool  -- ^ Remove literate markup?
+    , warnings  :: Bool  -- ^ Issue warnings?
+    } deriving (Show)
+
+-- | Default settings of boolean options.
+defaultBoolOptions :: BoolOptions
+defaultBoolOptions = BoolOptions { macros   = True,   locations = True
+                                 , hashline = True,   pragma    = False
+                                 , stripEol = False,  stripC89  = False
+                                 , lang     = True,   ansi      = False
+                                 , layout   = False,  literate  = False
+                                 , warnings = True }
+
+-- | Raw command-line options.  This is an internal intermediate data
+--   structure, used during option parsing only.
+data RawOption
+    = NoMacro
+    | NoLine
+    | LinePragma
+    | Pragma
+    | Text
+    | Strip
+    | StripEol
+    | Ansi
+    | Layout
+    | Unlit
+    | SuppressWarnings
+    | Macro (String,String)
+    | Path String
+    | PreInclude FilePath
+    | IgnoredForCompatibility
+      deriving (Eq, Show)
+
+flags :: [(String, RawOption)]
+flags = [ ("--nomacro", NoMacro)
+        , ("--noline",  NoLine)
+        , ("--linepragma", LinePragma)
+        , ("--pragma",  Pragma)
+        , ("--text",    Text)
+        , ("--strip",   Strip)
+        , ("--strip-eol",  StripEol)
+        , ("--hashes",  Ansi)
+        , ("--layout",  Layout)
+        , ("--unlit",   Unlit)
+        , ("--nowarn",  SuppressWarnings)
+        ]
+
+-- | Parse a single raw command-line option.  Parse failure is indicated by
+--   result Nothing.
+rawOption :: String -> Maybe RawOption
+rawOption x | isJust a = a
+    where a = lookup x flags
+rawOption ('-':'D':xs) = Just $ Macro (s, if null d then "1" else tail d)
+    where (s,d) = break (=='=') xs
+rawOption ('-':'U':xs) = Just $ IgnoredForCompatibility
+rawOption ('-':'I':xs) = Just $ Path $ trailing "/\\" xs
+rawOption xs | "--include="`isPrefixOf`xs
+            = Just $ PreInclude (drop 10 xs)
+rawOption _ = Nothing
+
+-- | Trim trailing elements of the second list that match any from
+--   the first list.  Typically used to remove trailing forward\/back
+--   slashes from a directory path.
+trailing :: (Eq a) => [a] -> [a] -> [a]
+trailing xs = reverse . dropWhile (`elem`xs) . reverse
+
+-- | Convert a list of RawOption to a BoolOptions structure.
+boolOpts :: [RawOption] -> BoolOptions
+boolOpts opts =
+  BoolOptions
+    { macros    = not (NoMacro `elem` opts)
+    , locations = not (NoLine  `elem` opts)
+    , hashline  = not (LinePragma `elem` opts)
+    , pragma    =      Pragma  `elem` opts
+    , stripEol  =      StripEol`elem` opts
+    , stripC89  =      StripEol`elem` opts || Strip `elem` opts
+    , lang      = not (Text    `elem` opts)
+    , ansi      =      Ansi    `elem` opts
+    , layout    =      Layout  `elem` opts
+    , literate  =      Unlit   `elem` opts
+    , warnings  = not (SuppressWarnings `elem` opts)
+    }
+
+-- | Parse all command-line options.
+parseOptions :: [String] -> Either String CpphsOptions
+parseOptions xs = f ([], [], []) xs
+  where
+    f (opts, ins, outs) (('-':'O':x):xs) = f (opts, ins, x:outs) xs
+    f (opts, ins, outs) (x@('-':_):xs) = case rawOption x of
+                                           Nothing -> Left x
+                                           Just a  -> f (a:opts, ins, outs) xs
+    f (opts, ins, outs) (x:xs) = f (opts, normalise x:ins, outs) xs
+    f (opts, ins, outs) []     =
+        Right CpphsOptions { infiles  = reverse ins
+                           , outfiles = reverse outs
+                           , defines  = [ x | Macro x <- reverse opts ]
+                           , includes = [ x | Path x  <- reverse opts ]
+                           , preInclude=[ x | PreInclude x <- reverse opts ]
+                           , boolopts = boolOpts opts
+                           }
+    normalise ('/':'/':filepath) = normalise ('/':filepath)
+    normalise (x:filepath)       = x:normalise filepath
+    normalise []                 = []

@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Position
+-- Copyright   :  2000-2004 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- Simple file position information, with recursive inclusion points.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.Position
+  ( Posn(..)
+  , newfile
+  , addcol, newline, tab, newlines, newpos
+  , cppline, haskline, cpp2hask
+  , filename, lineno, directory
+  , cleanPath
+  ) where
+
+import Data.List (isPrefixOf)
+
+-- | Source positions contain a filename, line, column, and an
+--   inclusion point, which is itself another source position,
+--   recursively.
+data Posn = Pn String !Int !Int (Maybe Posn)
+        deriving (Eq)
+
+instance Show Posn where
+      showsPrec _ (Pn f l c i) = showString f .
+                                 showString "  at line " . shows l .
+                                 showString " col " . shows c .
+                                 ( case i of
+                                    Nothing -> id
+                                    Just p  -> showString "\n    used by  " .
+                                               shows p )
+
+-- | Constructor.  Argument is filename.
+newfile :: String -> Posn
+newfile name = Pn (cleanPath name) 1 1 Nothing
+
+-- | Increment column number by given quantity.
+addcol :: Int -> Posn -> Posn
+addcol n (Pn f r c i) = Pn f r (c+n) i
+
+-- | Increment row number, reset column to 1.
+newline :: Posn -> Posn
+--newline (Pn f r _ i) = Pn f (r+1) 1 i
+newline (Pn f r _ i) = let r' = r+1 in r' `seq` Pn f r' 1 i
+
+-- | Increment column number, tab stops are every 8 chars.
+tab     :: Posn -> Posn
+tab     (Pn f r c i) = Pn f r (((c`div`8)+1)*8) i
+
+-- | Increment row number by given quantity.
+newlines :: Int -> Posn -> Posn
+newlines n (Pn f r _ i) = Pn f (r+n) 1 i
+
+-- | Update position with a new row, and possible filename.
+newpos :: Int -> Maybe String -> Posn -> Posn
+newpos r Nothing  (Pn f _ c i) = Pn f r c i
+newpos r (Just ('"':f)) (Pn _ _ c i) = Pn (init f) r c i
+newpos r (Just f)       (Pn _ _ c i) = Pn f r c i
+
+-- | Project the line number.
+lineno    :: Posn -> Int
+-- | Project the filename.
+filename  :: Posn -> String
+-- | Project the directory of the filename.
+directory :: Posn -> FilePath
+
+lineno    (Pn _ r _ _) = r
+filename  (Pn f _ _ _) = f
+directory (Pn f _ _ _) = dirname f
+
+
+-- | cpp-style printing of file position
+cppline :: Posn -> String
+cppline (Pn f r _ _) = "#line "++show r++" "++show f
+
+-- | haskell-style printing of file position
+haskline :: Posn -> String
+haskline (Pn f r _ _) = "{-# LINE "++show r++" "++show f++" #-}"
+
+-- | Conversion from a cpp-style "#line" to haskell-style pragma.
+cpp2hask :: String -> String
+cpp2hask line | "#line" `isPrefixOf` line = "{-# LINE "
+                                            ++unwords (tail (words line))
+                                            ++" #-}"
+              | otherwise = line
+
+-- | Strip non-directory suffix from file name (analogous to the shell
+--   command of the same name).
+dirname :: String -> String
+dirname  = reverse . safetail . dropWhile (not.(`elem`"\\/")) . reverse
+  where safetail [] = []
+        safetail (_:x) = x
+
+-- | Sigh.  Mixing Windows filepaths with unix is bad.  Make sure there is a
+--   canonical path separator.
+cleanPath :: FilePath -> FilePath
+cleanPath [] = []
+cleanPath ('\\':cs) = '/': cleanPath cs
+cleanPath (c:cs)    = c:   cleanPath cs

@@ -0,0 +1,55 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  ReadFirst
+-- Copyright   :  2004 Malcolm Wallace
+-- Licence     :  LGPL
+-- 
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- Read the first file that matches in a list of search paths.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.ReadFirst
+  ( readFirst
+  ) where
+
+import System.IO        (hPutStrLn, stderr)
+import System.Directory (doesFileExist)
+import Data.List      (intersperse)
+import Control.Monad     (when)
+import Language.Preprocessor.Cpphs.Position  (Posn,directory,cleanPath)
+
+-- | Attempt to read the given file from any location within the search path.
+--   The first location found is returned, together with the file content.
+--   (The directory of the calling file is always searched first, then
+--    the current directory, finally any specified search path.)
+readFirst :: String             -- ^ filename
+        -> Posn                 -- ^ inclusion point
+        -> [String]             -- ^ search path
+        -> Bool                 -- ^ report warnings?
+        -> IO ( FilePath
+              , String
+              )                 -- ^ discovered filepath, and file contents
+
+readFirst name demand path warn =
+    case name of
+       '/':nm -> try nm   [""]
+       _      -> try name (cons dd (".":path))
+  where
+    dd = directory demand
+    cons x xs = if null x then xs else x:xs
+    try name [] = do
+        when warn $
+          hPutStrLn stderr ("Warning: Can't find file \""++name
+                           ++"\" in directories\n\t"
+                           ++concat (intersperse "\n\t" (cons dd (".":path)))
+                           ++"\n  Asked for by: "++show demand)
+        return ("missing file: "++name,"")
+    try name (p:ps) = do
+        let file = cleanPath p++'/':cleanPath name
+        ok <- doesFileExist file
+        if not ok then try name ps
+          else do content <- readFile file
+                  return (file,content)

@@ -0,0 +1,82 @@+{-
+-- The main program for cpphs, a simple C pre-processor written in Haskell.
+
+-- Copyright (c) 2004 Malcolm Wallace
+-- This file is LGPL (relicensed from the GPL by Malcolm Wallace, October 2011).
+-}
+module Language.Preprocessor.Cpphs.RunCpphs ( runCpphs
+                                            , runCpphsPass1
+                                            , runCpphsPass2
+                                            , runCpphsReturningSymTab
+                                            ) where
+
+import Language.Preprocessor.Cpphs.CppIfdef (cppIfdef)
+import Language.Preprocessor.Cpphs.MacroPass(macroPass,macroPassReturningSymTab)
+import Language.Preprocessor.Cpphs.Options  (CpphsOptions(..), BoolOptions(..)
+                                            ,trailing)
+import Language.Preprocessor.Cpphs.Tokenise (deWordStyle, tokenise)
+import Language.Preprocessor.Cpphs.Position (cleanPath, Posn)
+import Language.Preprocessor.Unlit as Unlit (unlit)
+
+
+runCpphs :: CpphsOptions -> FilePath -> String -> IO String
+runCpphs options filename input = do
+  pass1 <- runCpphsPass1 options filename input
+  runCpphsPass2 (boolopts options) (defines options) filename pass1
+
+runCpphsPass1 :: CpphsOptions -> FilePath -> String -> IO [(Posn,String)]
+runCpphsPass1 options' filename input = do
+  let options= options'{ includes= map (trailing "\\/") (includes options') }
+  let bools  = boolopts options
+      preInc = case preInclude options of
+                 [] -> ""
+                 is -> concatMap (\f->"#include \""++f++"\"\n") is 
+                       ++ "#line 1 \""++cleanPath filename++"\"\n"
+
+  pass1 <- cppIfdef filename (defines options) (includes options) bools
+                    (preInc++input)
+  return pass1
+
+runCpphsPass2 :: BoolOptions -> [(String,String)] -> FilePath -> [(Posn,String)] -> IO String
+runCpphsPass2 bools defines filename pass1 = do
+  pass2 <- macroPass defines bools pass1
+  let result= if not (macros bools)
+              then if   stripC89 bools || stripEol bools
+                   then concatMap deWordStyle $
+                        tokenise (stripEol bools) (stripC89 bools)
+                                 (ansi bools) (lang bools) pass1
+                   else unlines (map snd pass1)
+              else pass2
+      pass3 = if literate bools then Unlit.unlit filename else id
+  return (pass3 result)
+
+runCpphsReturningSymTab :: CpphsOptions -> FilePath -> String
+             -> IO (String,[(String,String)])
+runCpphsReturningSymTab options' filename input = do
+  let options= options'{ includes= map (trailing "\\/") (includes options') }
+  let bools  = boolopts options
+      preInc = case preInclude options of
+                 [] -> ""
+                 is -> concatMap (\f->"#include \""++f++"\"\n") is 
+                       ++ "#line 1 \""++cleanPath filename++"\"\n"
+  (pass2,syms) <-
+      if macros bools then do
+          pass1 <- cppIfdef filename (defines options) (includes options)
+                            bools (preInc++input)
+          macroPassReturningSymTab (defines options) bools pass1
+      else do
+          pass1 <- cppIfdef filename (defines options) (includes options)
+                            bools{macros=True} (preInc++input)
+          (_,syms) <- macroPassReturningSymTab (defines options) bools pass1
+          pass1 <- cppIfdef filename (defines options) (includes options)
+                            bools (preInc++input)
+          let result = if   stripC89 bools || stripEol bools
+                       then concatMap deWordStyle $
+                            tokenise (stripEol bools) (stripC89 bools)
+                                     (ansi bools) (lang bools) pass1
+                       else init $ unlines (map snd pass1)
+          return (result,syms)
+
+  let pass3 = if literate bools then Unlit.unlit filename else id
+  return (pass3 pass2, syms)
+

@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  SymTab
+-- Copyright   :  2000-2004 Malcolm Wallace
+-- Licence     :  LGPL
+-- 
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  Stable
+-- Portability :  All
+--
+-- Symbol Table, based on index trees using a hash on the key.
+--   Keys are always Strings.  Stored values can be any type.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.SymTab
+  ( SymTab
+  , emptyST
+  , insertST
+  , deleteST
+  , lookupST
+  , definedST
+  , flattenST
+  , IndTree
+  ) where
+
+-- | Symbol Table.  Stored values are polymorphic, but the keys are
+--   always strings.
+type SymTab v = IndTree [(String,v)]
+
+emptyST   :: SymTab v
+insertST  :: (String,v) -> SymTab v -> SymTab v
+deleteST  :: String -> SymTab v -> SymTab v
+lookupST  :: String -> SymTab v -> Maybe v
+definedST :: String -> SymTab v -> Bool
+flattenST :: SymTab v -> [v]
+
+emptyST           = itgen maxHash []
+insertST (s,v) ss = itiap (hash s) ((s,v):)    ss id
+deleteST  s    ss = itiap (hash s) (filter ((/=s).fst)) ss id
+lookupST  s    ss = let vs = filter ((==s).fst) ((itind (hash s)) ss)
+                    in if null vs then Nothing
+                       else (Just . snd . head) vs
+definedST s    ss = let vs = filter ((==s).fst) ((itind (hash s)) ss)
+                    in (not . null) vs
+flattenST      ss = itfold (map snd) (++) ss
+
+
+----
+-- | Index Trees (storing indexes at nodes).
+
+data IndTree t = Leaf t | Fork Int (IndTree t) (IndTree t)
+     deriving Show
+
+itgen :: Int -> a -> IndTree a
+itgen 1 x = Leaf x
+itgen n x =
+  let n' = n `div` 2
+  in Fork n' (itgen n' x) (itgen (n-n') x)
+
+itiap :: --Eval a =>
+         Int -> (a->a) -> IndTree a -> (IndTree a -> b) -> b
+itiap _ f (Leaf x)       k = let fx = f x in {-seq fx-} (k (Leaf fx))
+itiap i f (Fork n lt rt) k =
+  if i<n then
+       itiap i f lt $ \lt' -> k (Fork n lt' rt)
+  else itiap (i-n) f rt $ \rt' -> k (Fork n lt rt')
+
+itind :: Int -> IndTree a -> a
+itind _ (Leaf x) = x
+itind i (Fork n lt rt) = if i<n then itind i lt else itind (i-n) rt
+
+itfold :: (a->b) -> (b->b->b) -> IndTree a -> b
+itfold leaf _fork (Leaf x) = leaf x
+itfold leaf  fork (Fork _ l r) = fork (itfold leaf fork l) (itfold leaf fork r)
+
+----
+-- Hash values
+
+maxHash :: Int -- should be prime
+maxHash = 101
+
+class Hashable a where
+    hashWithMax :: Int -> a -> Int
+    hash        :: a -> Int
+    hash = hashWithMax maxHash
+
+instance Enum a => Hashable [a] where
+    hashWithMax m = h 0
+        where h a []     = a
+              h a (c:cs) = h ((17*(fromEnum c)+19*a)`rem`m) cs
+
+----

@@ -0,0 +1,281 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Tokenise
+-- Copyright   :  2004 Malcolm Wallace
+-- Licence     :  LGPL
+--
+-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
+-- Stability   :  experimental
+-- Portability :  All
+--
+-- The purpose of this module is to lex a source file (language
+-- unspecified) into tokens such that cpp can recognise a replaceable
+-- symbol or macro-use, and do the right thing.
+-----------------------------------------------------------------------------
+
+module Language.Preprocessor.Cpphs.Tokenise
+  ( linesCpp
+  , reslash
+  , tokenise
+  , WordStyle(..)
+  , deWordStyle
+  , parseMacroCall
+  ) where
+
+import Data.Char
+import Language.Preprocessor.Cpphs.HashDefine
+import Language.Preprocessor.Cpphs.Position
+
+-- | A Mode value describes whether to tokenise a la Haskell, or a la Cpp.
+--   The main difference is that in Cpp mode we should recognise line
+--   continuation characters.
+data Mode = Haskell | Cpp
+
+-- | linesCpp is, broadly speaking, Prelude.lines, except that
+--   on a line beginning with a \#, line continuation characters are
+--   recognised.  In a line continuation, the newline character is
+--   preserved, but the backslash is not.
+linesCpp :: String -> [String]
+linesCpp  []                 = []
+linesCpp (x:xs) | x=='#'     = tok Cpp     ['#'] xs
+                | otherwise  = tok Haskell [] (x:xs)
+  where
+    tok Cpp   acc ('\\':'\n':ys)   = tok Cpp ('\n':acc) ys
+    tok _     acc ('\n':'#':ys)    = reverse acc: tok Cpp ['#'] ys
+    tok _     acc ('\n':ys)        = reverse acc: tok Haskell [] ys
+    tok _     acc []               = reverse acc: []
+    tok mode  acc (y:ys)           = tok mode (y:acc) ys
+
+-- | Put back the line-continuation characters.
+reslash :: String -> String
+reslash ('\n':xs) = '\\':'\n':reslash xs
+reslash (x:xs)    = x: reslash xs
+reslash   []      = []
+
+----
+-- | Submodes are required to deal correctly with nesting of lexical
+--   structures.
+data SubMode = Any | Pred (Char->Bool) (Posn->String->WordStyle)
+             | String Char | LineComment | NestComment Int
+             | CComment | CLineComment
+
+-- | Each token is classified as one of Ident, Other, or Cmd:
+--   * Ident is a word that could potentially match a macro name.
+--   * Cmd is a complete cpp directive (\#define etc).
+--   * Other is anything else.
+data WordStyle = Ident Posn String | Other String | Cmd (Maybe HashDefine)
+  deriving (Eq,Show)
+other :: Posn -> String -> WordStyle
+other _ s = Other s
+
+deWordStyle :: WordStyle -> String
+deWordStyle (Ident _ i) = i
+deWordStyle (Other i)   = i
+deWordStyle (Cmd _)     = "\n"
+
+-- | tokenise is, broadly-speaking, Prelude.words, except that:
+--    * the input is already divided into lines
+--    * each word-like "token" is categorised as one of {Ident,Other,Cmd}
+--    * \#define's are parsed and returned out-of-band using the Cmd variant
+--    * All whitespace is preserved intact as tokens.
+--    * C-comments are converted to white-space (depending on first param)
+--    * Parens and commas are tokens in their own right.
+--    * Any cpp line continuations are respected.
+--   No errors can be raised.
+--   The inverse of tokenise is (concatMap deWordStyle).
+tokenise :: Bool -> Bool -> Bool -> Bool -> [(Posn,String)] -> [WordStyle]
+tokenise _        _             _    _     [] = []
+tokenise stripEol stripComments ansi lang ((pos,str):pos_strs) =
+    (if lang then haskell else plaintext) Any [] pos pos_strs str
+ where
+    -- rules to lex Haskell
+  haskell :: SubMode -> String -> Posn -> [(Posn,String)]
+             -> String -> [WordStyle]
+  haskell Any acc p ls ('\n':'#':xs)      = emit acc $  -- emit "\n" $
+                                            cpp Any haskell [] [] p ls xs
+    -- warning: non-maximal munch on comment
+  haskell Any acc p ls ('-':'-':xs)       = emit acc $
+                                            haskell LineComment "--" p ls xs
+  haskell Any acc p ls ('{':'-':xs)       = emit acc $
+                                            haskell (NestComment 0) "-{" p ls xs
+  haskell Any acc p ls ('/':'*':xs)
+                          | stripComments = emit acc $
+                                            haskell CComment "  " p ls xs
+  haskell Any acc p ls ('/':'/':xs)
+                          | stripEol      = emit acc $
+                                            haskell CLineComment "  " p ls xs
+  haskell Any acc p ls ('"':xs)           = emit acc $
+                                            haskell (String '"') ['"'] p ls xs
+  haskell Any acc p ls ('\'':'\'':xs)     = emit acc $ -- TH type quote
+                                            haskell Any "''" p ls xs
+  haskell Any acc p ls ('\'':xs@('\\':_)) = emit acc $ -- escaped char literal
+                                            haskell (String '\'') "'" p ls xs
+  haskell Any acc p ls ('\'':x:'\'':xs)   = emit acc $ -- character literal
+                                            emit ['\'', x, '\''] $
+                                            haskell Any [] p ls xs
+  haskell Any acc p ls ('\'':xs)          = emit acc $ -- TH name quote
+                                            haskell Any "'" p ls xs
+  haskell Any acc p ls (x:xs) | single x  = emit acc $ emit [x] $
+                                            haskell Any [] p ls xs
+  haskell Any acc p ls (x:xs) | space x   = emit acc $
+                                            haskell (Pred space other) [x]
+                                                                        p ls xs
+  haskell Any acc p ls (x:xs) | symbol x  = emit acc $
+                                            haskell (Pred symbol other) [x]
+                                                                        p ls xs
+ -- haskell Any [] p ls (x:xs) | ident0 x  = id $
+  haskell Any acc p ls (x:xs) | ident0 x  = emit acc $
+                                            haskell (Pred ident1 Ident) [x]
+                                                                        p ls xs
+  haskell Any acc p ls (x:xs)             = haskell Any (x:acc) p ls xs
+
+  haskell pre@(Pred pred ws) acc p ls (x:xs)
+                        | pred x    = haskell pre (x:acc) p ls xs
+  haskell (Pred _ ws) acc p ls xs   = ws p (reverse acc):
+                                      haskell Any [] p ls xs
+  haskell (String c) acc p ls ('\\':x:xs)
+                        | x=='\\'   = haskell (String c) ('\\':'\\':acc) p ls xs
+                        | x==c      = haskell (String c) (c:'\\':acc) p ls xs
+  haskell (String c) acc p ls (x:xs)
+                        | x==c      = emit (c:acc) $ haskell Any [] p ls xs
+                        | otherwise = haskell (String c) (x:acc) p ls xs
+  haskell LineComment acc p ls xs@('\n':_) = emit acc $ haskell Any [] p ls xs
+  haskell LineComment acc p ls (x:xs)      = haskell LineComment (x:acc) p ls xs
+  haskell (NestComment n) acc p ls ('{':'-':xs)
+                                    = haskell (NestComment (n+1))
+                                                            ("-{"++acc) p ls xs
+  haskell (NestComment 0) acc p ls ('-':'}':xs)
+                                    = emit ("}-"++acc) $ haskell Any [] p ls xs
+  haskell (NestComment n) acc p ls ('-':'}':xs)
+                                    = haskell (NestComment (n-1))
+                                                            ("}-"++acc) p ls xs
+  haskell (NestComment n) acc p ls (x:xs) = haskell (NestComment n) (x:acc)
+                                                                        p ls xs
+  haskell CComment acc p ls ('*':'/':xs)  = emit ("  "++acc) $
+                                            haskell Any [] p ls xs
+  haskell CComment acc p ls (x:xs)        = haskell CComment (white x:acc) p ls xs
+  haskell CLineComment acc p ls xs@('\n':_)= emit acc $ haskell Any [] p ls xs
+  haskell CLineComment acc p ls (_:xs)    = haskell CLineComment (' ':acc)
+                                                                       p ls xs
+  haskell mode acc _ ((p,l):ls) []        = haskell mode acc p ls ('\n':l)
+  haskell _    acc _ [] []                = emit acc $ []
+
+  -- rules to lex Cpp
+  cpp :: SubMode -> (SubMode -> String -> Posn -> [(Posn,String)]
+                     -> String -> [WordStyle])
+         -> String -> [String] -> Posn -> [(Posn,String)]
+         -> String -> [WordStyle]
+  cpp mode next word line pos remaining input =
+    lexcpp mode word line remaining input
+   where
+    lexcpp Any w l ls ('/':'*':xs)   = lexcpp (NestComment 0) "" (w*/*l) ls xs
+    lexcpp Any w l ls ('/':'/':xs)   = lexcpp LineComment "  " (w*/*l) ls xs
+    lexcpp Any w l ((p,l'):ls) ('\\':[])  = cpp Any next [] ("\n":w*/*l) p ls l'
+    lexcpp Any w l ls ('\\':'\n':xs) = lexcpp Any [] ("\n":w*/*l) ls xs
+    lexcpp Any w l ls xs@('\n':_)    = Cmd (parseHashDefine ansi
+                                                           (reverse (w*/*l))):
+                                       next Any [] pos ls xs
+ -- lexcpp Any w l ls ('"':xs)     = lexcpp (String '"') ['"'] (w*/*l) ls xs
+ -- lexcpp Any w l ls ('\'':xs)    = lexcpp (String '\'') "'"  (w*/*l) ls xs
+    lexcpp Any w l ls ('"':xs)       = lexcpp Any [] ("\"":(w*/*l)) ls xs
+    lexcpp Any w l ls ('\'':xs)      = lexcpp Any [] ("'": (w*/*l)) ls xs
+    lexcpp Any [] l ls (x:xs)
+                    | ident0 x  = lexcpp (Pred ident1 Ident) [x] l ls xs
+ -- lexcpp Any w l ls (x:xs) | ident0 x  = lexcpp (Pred ident1 Ident) [x] (w*/*l) ls xs
+    lexcpp Any w l ls (x:xs)
+                    | single x  = lexcpp Any [] ([x]:w*/*l) ls xs
+                    | space x   = lexcpp (Pred space other) [x] (w*/*l) ls xs
+                    | symbol x  = lexcpp (Pred symbol other) [x] (w*/*l) ls xs
+                    | otherwise = lexcpp Any (x:w) l ls xs
+    lexcpp pre@(Pred pred _) w l ls (x:xs)
+                    | pred x    = lexcpp pre (x:w) l ls xs
+    lexcpp (Pred _ _) w l ls xs = lexcpp Any [] (w*/*l) ls xs
+    lexcpp (String c) w l ls ('\\':x:xs)
+                    | x=='\\'   = lexcpp (String c) ('\\':'\\':w) l ls xs
+                    | x==c      = lexcpp (String c) (c:'\\':w) l ls xs
+    lexcpp (String c) w l ls (x:xs)
+                    | x==c      = lexcpp Any [] ((c:w)*/*l) ls xs
+                    | otherwise = lexcpp (String c) (x:w) l ls xs
+    lexcpp LineComment w l ((p,l'):ls) ('\\':[])
+                             = cpp LineComment next [] (('\n':w)*/*l) pos ls l'
+    lexcpp LineComment w l ls ('\\':'\n':xs)
+                                = lexcpp LineComment [] (('\n':w)*/*l) ls xs
+    lexcpp LineComment w l ls xs@('\n':_) = lexcpp Any w l ls xs
+    lexcpp LineComment w l ls (_:xs)      = lexcpp LineComment (' ':w) l ls xs
+    lexcpp (NestComment _) w l ls ('*':'/':xs)
+                                          = lexcpp Any [] (w*/*l) ls xs
+    lexcpp (NestComment n) w l ls (x:xs)  = lexcpp (NestComment n) (white x:w) l
+                                                                        ls xs
+    lexcpp mode w l ((p,l'):ls) []        = cpp mode next w l p ls ('\n':l')
+    lexcpp _    _ _ []          []        = []
+
+    -- rules to lex non-Haskell, non-cpp text
+  plaintext :: SubMode -> String -> Posn -> [(Posn,String)]
+            -> String -> [WordStyle]
+  plaintext Any acc p ls ('\n':'#':xs)  = emit acc $  -- emit "\n" $
+                                          cpp Any plaintext [] [] p ls xs
+  plaintext Any acc p ls ('/':'*':xs)
+                           | stripComments = emit acc $
+                                             plaintext CComment "  " p ls xs
+  plaintext Any acc p ls ('/':'/':xs)
+                                | stripEol = emit acc $
+                                             plaintext CLineComment "  " p ls xs
+  plaintext Any acc p ls (x:xs) | single x = emit acc $ emit [x] $
+                                             plaintext Any [] p ls xs
+  plaintext Any acc p ls (x:xs) | space x  = emit acc $
+                                             plaintext (Pred space other) [x]
+                                                                        p ls xs
+  plaintext Any acc p ls (x:xs) | ident0 x = emit acc $
+                                             plaintext (Pred ident1 Ident) [x]
+                                                                        p ls xs
+  plaintext Any acc p ls (x:xs)            = plaintext Any (x:acc) p ls xs
+  plaintext pre@(Pred pred ws) acc p ls (x:xs)
+                                | pred x   = plaintext pre (x:acc) p ls xs
+  plaintext (Pred _ ws) acc p ls xs        = ws p (reverse acc):
+                                             plaintext Any [] p ls xs
+  plaintext CComment acc p ls ('*':'/':xs) = emit ("  "++acc) $
+                                             plaintext Any [] p ls xs
+  plaintext CComment acc p ls (x:xs)       = plaintext CComment (white x:acc) p ls xs
+  plaintext CLineComment acc p ls xs@('\n':_)
+                                        = emit acc $ plaintext Any [] p ls xs
+  plaintext CLineComment acc p ls (_:xs)= plaintext CLineComment (' ':acc)
+                                                                       p ls xs
+  plaintext mode acc _ ((p,l):ls) []    = plaintext mode acc p ls ('\n':l)
+  plaintext _    acc _ [] []            = emit acc $ []
+
+  -- predicates for lexing Haskell.
+  ident0 x = isAlpha x    || x `elem` "_`"
+  ident1 x = isAlphaNum x || x `elem` "'_`"
+  symbol x = x `elem` ":!#$%&*+./<=>?@\\^|-~"
+  single x = x `elem` "(),[];{}"
+  space  x = x `elem` " \t"
+  -- conversion of comment text to whitespace
+  white '\n' = '\n'
+  white '\r' = '\r'
+  white _    = ' '
+  -- emit a token (if there is one) from the accumulator
+  emit ""  = id
+  emit xs  = (Other (reverse xs):)
+  -- add a reversed word to the accumulator
+  "" */* l = l
+  w */* l  = reverse w : l
+  -- help out broken Haskell compilers which need balanced numbers of C
+  -- comments in order to do import chasing :-)  ----->   */*
+
+
+-- | Parse a possible macro call, returning argument list and remaining input
+parseMacroCall :: Posn -> [WordStyle] -> Maybe ([[WordStyle]],[WordStyle])
+parseMacroCall p = call . skip
+  where
+    skip (Other x:xs) | all isSpace x = skip xs
+    skip xss                          = xss
+    call (Other "(":xs)   = (args (0::Int) [] [] . skip) xs
+    call _                = Nothing
+    args 0 w acc (   Other ")" :xs)  = Just (reverse (addone w acc), xs)
+    args 0 w acc (   Other "," :xs)  = args 0     []   (addone w acc) (skip xs)
+    args n w acc (x@(Other "("):xs)  = args (n+1) (x:w)         acc    xs
+    args n w acc (x@(Other ")"):xs)  = args (n-1) (x:w)         acc    xs
+    args n w acc (   Ident _ v :xs)  = args n     (Ident p v:w) acc    xs
+    args n w acc (x@(Other _)  :xs)  = args n     (x:w)         acc    xs
+    args _ _ _   _                   = Nothing
+    addone w acc = reverse (skip w): acc

@@ -0,0 +1,72 @@+-- | Part of this code is from "Report on the Programming Language Haskell",
+--   version 1.2, appendix C.
+module Language.Preprocessor.Unlit (unlit) where
+
+import Data.Char
+import Data.List (isPrefixOf)
+
+data Classified = Program String | Blank | Comment
+                | Include Int String | Pre String
+
+classify :: [String] -> [Classified]
+classify []                = []
+classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs
+   where allProg [] = []  -- Should give an error message,
+                          -- but I have no good position information.
+         allProg (('\\':x):xs) |  "end{code}"`isPrefixOf`x = Blank : classify xs
+         allProg (x:xs) = Program x:allProg xs
+classify (('>':x):xs)      = Program (' ':x) : classify xs
+classify (('#':x):xs)      = (case words x of
+                                (line:rest) | all isDigit line
+                                   -> Include (read line) (unwords rest)
+                                _  -> Pre x
+                             ) : classify xs
+--classify (x:xs) | "{-# LINE" `isPrefixOf` x = Program x: classify xs
+classify (x:xs) | all isSpace x = Blank:classify xs
+classify (x:xs)                 = Comment:classify xs
+
+unclassify :: Classified -> String
+unclassify (Program s) = s
+unclassify (Pre s)     = '#':s
+unclassify (Include i f) = '#':' ':show i ++ ' ':f
+unclassify Blank       = ""
+unclassify Comment     = ""
+
+-- | 'unlit' takes a filename (for error reports), and transforms the
+--   given string, to eliminate the literate comments from the program text.
+unlit :: FilePath -> String -> String
+unlit file lhs = (unlines
+                 . map unclassify
+                 . adjacent file (0::Int) Blank
+                 . classify) (inlines lhs)
+
+adjacent :: FilePath -> Int -> Classified -> [Classified] -> [Classified]
+adjacent file 0 _             (x              :xs) = x : adjacent file 1 x xs -- force evaluation of line number
+adjacent file n y@(Program _) (x@Comment      :xs) = error (message file n "program" "comment")
+adjacent file n y@(Program _) (x@(Include i f):xs) = x: adjacent f    i     y xs
+adjacent file n y@(Program _) (x@(Pre _)      :xs) = x: adjacent file (n+1) y xs
+adjacent file n y@Comment     (x@(Program _)  :xs) = error (message file n "comment" "program")
+adjacent file n y@Comment     (x@(Include i f):xs) = x: adjacent f    i     y xs
+adjacent file n y@Comment     (x@(Pre _)      :xs) = x: adjacent file (n+1) y xs
+adjacent file n y@Blank       (x@(Include i f):xs) = x: adjacent f    i     y xs
+adjacent file n y@Blank       (x@(Pre _)      :xs) = x: adjacent file (n+1) y xs
+adjacent file n _             (x@next         :xs) = x: adjacent file (n+1) x xs
+adjacent file n _             []                   = []
+
+message :: String -> Int -> String -> String -> String
+message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"
+message []     n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"
+message file   n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"
+
+
+-- Re-implementation of 'lines', for better efficiency (but decreased laziness).
+-- Also, importantly, accepts non-standard DOS and Mac line ending characters.
+inlines :: String -> [String]
+inlines s = lines' s id
+  where
+  lines' []             acc = [acc []]
+  lines' ('\^M':'\n':s) acc = acc [] : lines' s id      -- DOS
+  lines' ('\^M':s)      acc = acc [] : lines' s id      -- MacOS
+  lines' ('\n':s)       acc = acc [] : lines' s id      -- Unix
+  lines' (c:s)          acc = lines' s (acc . (c:))
+

@@ -0,0 +1,9 @@+{-# LANGUAGE DuplicateRecordFields #-}
+module Decl.AmbiguousFields where
+
+data A = A { x, y :: Int }
+data B = B { x, y :: Int }
+
+f :: A -> Int
+f = x
+

@@ -0,0 +1,8 @@+module Decl.AnnPragma where
+{-# ANN module (Just "Hello") #-}
+{-# ANN f (Just "Hello") #-}
+f :: Int -> Int
+f a = a + 1
+
+{-# ANN type A (Just "Hello") #-}
+data A = A

@@ -0,0 +1,10 @@+module Decl.ClassInfix where
+
+import Control.Applicative
+
+class Applicative f => MonoidApplicative f where
+   infixl 4 +<*>
+   (+<*>) :: f (a -> a) -> f a -> f a
+
+   infixl 5 ><
+   (><) :: Monoid a => f a -> f a -> f a

@@ -0,0 +1,9 @@+{-# LANGUAGE TypeFamilies #-}
+module Decl.ClosedTypeFamily where
+
+type family F a where
+  F Int  = Bool
+  F Bool = Char
+  F a    = Bool
+
+type family ClosedEmpty t where

@@ -0,0 +1,16 @@+{-# LANGUAGE PatternSynonyms #-}
+module Decl.CompletePragma where
+
+data Choice a = Choice Bool a
+
+pattern LeftChoice :: a -> Choice a
+pattern LeftChoice a = Choice False a
+
+pattern RightChoice :: a -> Choice a
+pattern RightChoice a = Choice True a
+
+{-# COMPLETE LeftChoice, RightChoice #-}
+
+foo :: Choice Int -> Int
+foo (LeftChoice n) = n * 2
+foo (RightChoice n) = n - 2

@@ -0,0 +1,10 @@+{-# LANGUAGE TypeOperators #-}
+module Decl.CtorOp where
+
+data a :+: b = a :+: b
+
+data (a :!: b) c = a c :!: b c
+
+data ((:-:) a) b = a :-: b
+
+data (:*:) a b = a :*: b

@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies #-}
+module Decl.DataFamily where
+
+data family Array :: * -> *
+
+data instance Array () = UnitArray Int deriving Show

@@ -0,0 +1,6 @@+{-# LANGUAGE GADTs, KindSignatures, TypeFamilies #-}
+module Decl.DataInstanceGADT where
+
+data family GadtFam (a :: *) (b :: *)
+data instance GadtFam c d where
+  MkGadtFam1 :: x -> y -> GadtFam y x

@@ -0,0 +1,5 @@+module Decl.DataType where
+
+data EmptyData
+
+data A = B Int | C

@@ -0,0 +1,5 @@+module Decl.DataTypeDerivings where
+
+data A = A deriving (Eq, Show)
+data B = B deriving (Eq)
+data C = C deriving Eq

@@ -0,0 +1,3 @@+module Decl.DefaultDecl where
+
+default ()

@@ -0,0 +1,4 @@+module Decl.FunBind where
+
+f 0 = 1
+f x = x

@@ -0,0 +1,5 @@+module Decl.FunFixity where
+
+infixl `snoc`
+snoc :: [a] -> a -> [a]
+snoc xs x = xs ++ [x]

@@ -0,0 +1,5 @@+module Decl.FunGuards where
+
+f 0 = 1
+f x | even x = 0
+    | otherwise = 2

@@ -0,0 +1,6 @@+{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-}
+module Decl.FunctionalDeps where
+
+class C a b | a -> b, b -> a where
+  trf :: a -> b
+  

@@ -0,0 +1,9 @@+{-# LANGUAGE GADTs, KindSignatures, DeriveDataTypeable #-}
+module Decl.GADT where
+
+import Data.Typeable
+
+data DMap k f where
+    Tip :: DMap k f
+    Bin :: !Int -> !(k v) -> f v -> !(DMap k f) -> !(DMap k f) -> DMap k f
+    deriving Typeable

@@ -0,0 +1,5 @@+{-# LANGUAGE GADTs #-}
+module Decl.GadtConWithCtx where
+
+data Concurrently m a where
+  Concurrently :: Monad m => { runConcurrently :: m a } -> Concurrently m a

@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds, TypeOperators, KindSignatures, TypeFamilies #-}
+module Decl.InfixAssertion where
+
+import GHC.TypeLits
+
+data Proxy (n :: Nat) = Proxy
+
+divSNat :: (1 <= b) => Proxy b -> Proxy b
+divSNat n = n

@@ -0,0 +1,8 @@+{-# LANGUAGE TypeOperators, TypeFamilies #-}
+module Decl.InfixInstances where
+
+data Zipper h i a = Zipper
+data (:@) a i
+infixl 8 :>
+type family (:>) h p
+type instance h :> (a :@ i) = Zipper h i a

@@ -0,0 +1,10 @@+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+module Decl.InfixPatSyn where
+
+pattern x :. xs <- (uncons -> Just (x,xs)) where
+  x:.xs = cons x xs
+infixr 5 :.
+
+cons x xs = x:xs
+uncons (x:xs) = Just (x,xs)
+uncons [] = Nothing

@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
+module Decl.InjectiveTypeFamily where
+
+type family Array a = r | r -> a
+
+type instance Array () = Int

@@ -0,0 +1,5 @@+module Decl.InlinePragma where
+
+comp :: (b -> c) -> (a -> b) -> a -> c
+{-# INLINE CONLIKE [~1] comp #-}
+comp f g = \x -> f (g x)

@@ -0,0 +1,10 @@+{-# LANGUAGE TypeOperators, TypeFamilies #-}
+module Decl.InstanceFamily where
+
+import GHC.Generics
+
+class HasTrie a where
+  data (:->:) a :: * -> *
+
+instance (HasTrie (f x)) => HasTrie (M1 i t f x) where
+  data (M1 i t f x :->: b) = M1Trie (f x :->: b)

@@ -0,0 +1,11 @@+{-# LANGUAGE FlexibleInstances #-}
+module Decl.InstanceOverlaps where
+
+data A a = A a
+
+instance {-# OVERLAPPING #-} Show (A String) where
+  show (A a) = a
+instance {-# OVERLAPS #-} Show a => Show (A [a]) where
+  show (A a) = show a
+instance {-# OVERLAPPABLE #-} Show (A a) where
+  show (A _) = "A"

@@ -0,0 +1,7 @@+module Decl.InstanceSpec where
+
+data Foo a = Foo a
+
+instance (Eq a) => Eq (Foo a) where 
+   {-# SPECIALIZE instance Eq (Foo Char) #-}
+   Foo a == Foo b = a == b

@@ -0,0 +1,7 @@+module Decl.LocalBindingInDo where
+
+x :: Maybe ()
+x = do let y = f a
+             where a = ()
+       return y
+    where f = id

@@ -0,0 +1,9 @@+module Decl.LocalBindings where
+
+f x = g x
+  where g :: Int -> Int
+        g = id
+        
+f' x | even x = g x
+  where g :: Int -> Int
+        g = id

@@ -0,0 +1,6 @@+module Decl.LocalFixity where
+
+x = 1 `f` 2
+  where f :: Int -> Int -> Int
+        f a b = a + b 
+        infixl 6 `f`

@@ -0,0 +1,23 @@+module Decl.MinimalPragma where
+
+class A x where
+  f, g :: x -> ()
+  {-# MINIMAL f,g #-}
+
+class B x where
+  fb, gb :: x -> ()
+  fb = gb
+  gb = fb
+  {-# MINIMAL fb | gb #-}
+
+class C x where
+  fc, gc, hc :: x -> x
+  gc = fc
+  hc = fc
+  fc = gc . hc
+  {-# MINIMAL fc | (gc, hc) #-}
+
+class D x where
+  fd :: x -> x
+  fd = id
+  {-# MINIMAL #-}

@@ -0,0 +1,11 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}
+module Decl.MixedInstance where
+
+data Canvas = Canvas
+data V2 = V2
+
+class Backend c v e where
+  data Options c v e :: *
+
+instance Backend Canvas V2 Double where
+  data Options Canvas V2 Double = CanvasOptions

@@ -0,0 +1,12 @@+module Decl.MultipleFixity where
+
+f :: Int -> Int -> Int
+f a b = a + b
+
+g = f
+
+infixl 6 `f`, `g`
+
+h = f
+
+infixl 5 `h`

@@ -0,0 +1,6 @@+module Decl.MultipleSigs where
+
+f, g :: Int -> Int -> Int
+f a b = a + b
+
+g = f

@@ -0,0 +1,6 @@+module Decl.OperatorBind where
+
+a >< b = a ++ b
+
+(<+>) :: Int -> Int -> Int -> Int
+(a <+> b) c = a + b + c

@@ -0,0 +1,6 @@+module Decl.OperatorDecl where
+
+(-!-) :: Int -> Int -> Int
+(-!-) a b = a + b
+
+test = (-!-) (1 -!- 2) 3

@@ -0,0 +1,5 @@+module Decl.ParamDataType where
+
+data A a = B Int | C a
+
+data X a = X a

@@ -0,0 +1,3 @@+module Decl.PatternBind where
+
+(x,y) | 1 == 1 = (1,2)

@@ -0,0 +1,28 @@+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+module Decl.PatternSynonym where
+
+data Type = App String [Type]
+
+pattern Arrow :: Type -> Type -> Type
+pattern Arrow t1 t2 = App "->"    [t1, t2]
+
+
+pattern Int        <- App "Int"   []
+
+pattern Maybe t    <- App "Maybe" [t]
+   where Maybe (App "()" []) = App "Bool" []
+         Maybe t = App "Maybe" [t]
+
+pattern (:<) :: [a] -> a -> [a]
+pattern (:<) xs x <- ((\ys -> (init ys,last ys)) -> (xs,x))
+  where
+    (:<) xs x = xs ++ [x]
+
+------ this is not supported yet
+-- class ListLike a where
+--   pattern Head :: e -> a e0
+--   pattern Tail :: a e -> a e
+
+-- instance ListLike [] where
+--   pattern Head h = h:_
+--   pattern Tail t = _:t

@@ -0,0 +1,8 @@+{-# LANGUAGE PatternSynonyms #-}
+module Decl.RecordPatternSynonyms where
+
+pattern XPoint {xp} <- (xp, 0) where XPoint xp = (xp, 0)
+
+pattern Point {x, y} = (x, y)
+
+r = (0, 0) { x = 1 }

@@ -0,0 +1,3 @@+module Decl.RecordType where
+
+data A = B { valB, extra :: Int, qq :: Double } | C

@@ -0,0 +1,3 @@+module Decl.RewriteRule where
+
+{-# RULES "map/map" forall f g xs . map f (map g xs) = map (f . g) xs #-}

@@ -0,0 +1,5 @@+module Decl.SpecializePragma where
+
+hammeredLookup :: Ord key => [(key, value)] -> key -> value
+{-# SPECIALIZE hammeredLookup :: [(String, value)] -> String -> value, [(Char, value)] -> Char -> value #-}
+hammeredLookup = undefined

@@ -0,0 +1,6 @@+{-# LANGUAGE StandaloneDeriving #-}
+module Decl.StandaloneDeriving where
+
+data WrapStr = WrapStr String 
+
+deriving instance Eq WrapStr

@@ -0,0 +1,13 @@+{-# LANGUAGE TypeFamilies #-}
+module Decl.TypeClass where
+
+class EmptyClass a
+
+class Show a => C a where
+  type X a :: *
+  type X a = Int
+  data Q a :: *
+  
+  f :: a -> String
+  f = show
+  

@@ -0,0 +1,8 @@+module Decl.TypeClassMinimal where
+
+class Eq' a where
+    (=.=) :: a -> a -> Bool
+    (/.=) :: a -> a -> Bool
+    x =.= y = not (x /.= y)
+    x /.= y = not (x =.= y)
+    {-# MINIMAL (=.=) | (/.=) #-}

@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies #-}
+module Decl.TypeFamily where
+
+type family Array a :: *
+
+type instance Array () = Int

@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies #-}
+module Decl.TypeFamilyKindSig where
+
+type family Array (a :: *) :: *
+
+type instance Array () = Int

@@ -0,0 +1,14 @@+{-# LANGUAGE TypeFamilies, InstanceSigs #-}
+module Decl.TypeInstance where
+
+import Decl.TypeClass
+
+data A = A deriving Show
+
+instance C A where
+  type X A = Int
+  data Q A = Bool
+
+  f :: A -> String
+  f A = "XXX"
+  

@@ -0,0 +1,5 @@+{-# LANGUAGE RoleAnnotations #-}
+module Decl.TypeRole where
+
+type role Foo representational representational
+data Foo a b = Foo Int

@@ -0,0 +1,3 @@+module Decl.TypeSynonym where
+
+type List = Int

@@ -0,0 +1,3 @@+module Decl.ValBind where
+
+x = 1

@@ -0,0 +1,8 @@+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+module Decl.ViewPatternSynonym where
+
+data Uncert a = Un a a
+
+pattern x :+/- dx <- Un x (sqrt->dx)
+  where
+    x :+/- dx = Un x (dx*dx)

@@ -0,0 +1,10 @@+{-# LANGUAGE Arrows #-}
+module Expr.ArrowNotation where
+
+import Control.Arrow
+
+addA :: Arrow a => a b Int -> a b Int -> a b Int
+addA f g = proc x -> do
+                y <- f -< x
+                z <- g -< x
+                returnA -< y + z

@@ -0,0 +1,8 @@+module Expr.Case where
+
+x = 12
+
+a = case x of 1 -> 0
+              _ -> 1
+
+b = case x of { 1 -> 0; _ -> 1 }

@@ -0,0 +1,15 @@+module Expr.DoNotation where
+
+import Control.Monad.Identity
+
+x1 :: Identity ()
+x1 = return ()
+
+x2 :: Identity ()
+x2 = do return ()
+
+x3 :: Identity ()
+x3 = do { return () }
+
+x4 :: Identity Int
+x4 = do { one <- Identity 1; return (one + 1) }

@@ -0,0 +1,8 @@+{-# LANGUAGE EmptyCase #-}
+module Expr.EmptyCase where
+
+x = 12
+
+a = case x of 
+
+b = case x of {}

@@ -0,0 +1,6 @@+module Expr.EmptyLet where
+
+a = let in ()
+
+m = do let
+       putStrLn "hello"

@@ -0,0 +1,6 @@+module Expr.FunSection where
+
+data Rule = Rule {
+    rulePath :: String -> Bool }
+
+f r = filter (`rulePath` r)

@@ -0,0 +1,31 @@+{-# LANGUAGE ParallelListComp, 
+             TransformListComp,
+             MonadComprehensions,
+             RecordWildCards #-}
+module Expr.GeneralizedListComp where
+
+import GHC.Exts
+import qualified Data.Map as M
+import Data.Ord (comparing)
+
+data Character = Character
+  { firstName :: String
+  , lastName :: String
+  , birthYear :: Int
+  } deriving (Show, Eq)
+
+friends :: [Character]
+friends = [ Character "Phoebe" "Buffay" 1963
+          , Character "Chandler" "Bing" 1969
+          , Character "Rachel" "Green" 1969
+          , Character "Joey" "Tribbiani" 1967
+          , Character "Monica" "Geller" 1964
+          , Character "Ross" "Geller" 1966
+          ]
+          
+oldest :: Int -> [Character] -> [String]
+oldest k tbl = [ firstName ++ " " ++ lastName
+               | Character{..} <- tbl
+               , then sortWith by birthYear
+               , then take k
+               ]

@@ -0,0 +1,4 @@+module Expr.If where
+
+b = 12
+a = if b > 3 then 1 else 0

@@ -0,0 +1,11 @@+{-# LANGUAGE LambdaCase, EmptyCase #-}
+module Expr.LambdaCase where
+
+a = \case 1 -> 0
+          _ -> 1
+
+b = \case { 1 -> 0; _ -> 1 }
+
+c = \case {}
+
+d = \case

@@ -0,0 +1,3 @@+module Expr.ListComp where
+
+ls = [ x+y | x <- [1..5], y <- [1..5]]

@@ -0,0 +1,7 @@+{-# LANGUAGE MultiWayIf #-}
+module Expr.MultiwayIf where
+
+b = 12
+a = if | b > 3     -> 1
+       | b < -5    -> 2
+       | otherwise -> 3

@@ -0,0 +1,4 @@+module Expr.Negate where
+
+y = 1
+x = -y 

@@ -0,0 +1,5 @@+module Expr.Operator where
+
+x = 1 + 2
+y = (+) 1 2
+z = 1 `mod` 2

@@ -0,0 +1,4 @@+{-# LANGUAGE ParallelListComp #-}
+module Expr.ParListComp where
+
+ls = [ x+y | x <- [1..5] | y <- [1..5]]

@@ -0,0 +1,3 @@+module Expr.ParenName where
+
+a x y = (mod) x y

@@ -0,0 +1,10 @@+{-# LANGUAGE RecordWildCards #-}
+module Expr.PatternAndDo where
+
+import Control.Monad
+import Control.Monad.Identity
+
+data A = A { x :: Int }
+
+a = forM_ [] $ \A {..} -> do
+      Identity "Hello"

@@ -0,0 +1,6 @@+{-# LANGUAGE NamedFieldPuns #-}
+module Expr.RecordPuns where
+
+data Point = Point { x :: Int, y :: Int }
+
+f (Point {y}) = y

@@ -0,0 +1,6 @@+{-# LANGUAGE RecordWildCards #-}
+module Expr.RecordWildcards where
+
+data Point = Point { x :: Int, y :: Int }
+
+p1 = let x = 3; y = 4 in Point { x = 1, .. }

@@ -0,0 +1,9 @@+{-# LANGUAGE RecursiveDo #-}
+module Expr.RecursiveDo where
+
+justOnes = mdo xs <- Just (1:xs)
+               return (map negate xs)
+
+justOnes' = do rec xs <- Just (1:xs)
+                   return (map negate xs)
+               return xs

@@ -0,0 +1,4 @@+module Expr.SccPragma where
+
+f x = {-# SCC "drawComponent" #-}
+        case x of () -> ()

@@ -0,0 +1,4 @@+module Expr.Sections where
+
+x = (1+)
+y = (+1)

@@ -0,0 +1,7 @@+module Expr.SemicolonDo where
+
+import Control.Monad.Identity
+
+a = do { n <- Identity ()
+            ; return ()
+            }

@@ -0,0 +1,16 @@+{-# LANGUAGE StaticPointers #-}
+module Expr.StaticPtr where
+
+import GHC.StaticPtr
+
+inc :: Int -> Int
+inc x = x + 1
+
+ref1, ref3, ref4 :: StaticPtr Int
+ref2 :: StaticPtr (Int -> Int)
+ref5 :: Int -> StaticPtr Int
+ref1 = static 1
+ref2 = static inc
+ref3 = static (inc 1)
+ref4 = static ((\x -> x + 1) (1 :: Int))
+ref5 y = static (let x = 1 in x)

@@ -0,0 +1,7 @@+{-# LANGUAGE TupleSections #-}
+module Expr.TupleSections where
+
+f1 = (1,,)
+f2 = (,1)
+
+x = (,("x", []))

@@ -0,0 +1,13 @@+{-# LANGUAGE UnboxedSums #-}
+module Expr.UnboxedSum where
+
+f = ()
+  where
+    expr :: (# Int | Bool #)
+    expr = (# | True #)
+
+    expr2 :: (# Int | Bool #)
+    expr2 = (# 3 | #)
+
+    expr3 :: (# Int | String | Bool #)
+    expr3 = (# | "aaa" | #)

@@ -0,0 +1,7 @@+{-# LANGUAGE UnicodeSyntax #-}
+module Expr.UnicodeSyntax where
+    
+import Data.List.Unicode ((∪))
+
+main ∷ IO ()
+main = print $ [1, 2, 3] ∪ [1, 3, 5]

@@ -0,0 +1,149 @@+{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators, MultiParamTypeClasses, FlexibleInstances, PolyKinds, UndecidableInstances, AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, FlexibleContexts #-}
+
+module Control.Instances.Morph (GenMorph(..), Morph(..)) where
+
+import Control.Instances.ShortestPath
+
+import Control.Monad.Identity
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.List
+import Control.Monad.State
+import Data.Maybe
+import Data.Proxy
+import GHC.TypeLits
+import Control.Instances.TypeLevelPrelude
+
+-- | States that 'm1' can be represented with 'm2'.
+-- That is because 'm2' contains more infromation than 'm1'.
+--
+-- The 'MMorph' relation defines a natural transformation from 'm1' to 'm2'
+-- that keeps the following laws:
+--
+-- > morph (return x)  =  return x
+-- > morph (m >>= f)   =  morph m >>= morph . f
+-- 
+-- It is a reflexive and transitive relation.
+--
+class Morph (m1 :: * -> *) (m2 :: * -> *) where
+  -- | Lifts the first monad into the second.
+  morph :: m1 a -> m2 a
+  
+instance GenMorph DB m1 m2 => Morph m1 m2 where
+  morph = genMorph db
+  
+-- | A generalized version of 'Morph'. Can work on different
+-- rulesets, so this should be used if the ruleset is to be extended.
+class GenMorph db (m1 :: * -> *) (m2 :: * -> *) where
+  -- | Lifts the first monad into the second.
+  genMorph :: db -> m1 a -> m2 a
+  
+instance ( fl ~ (TransformPath (PathFromList (ShortestPath (ToMorphRepo DB) x y)))
+         , CorrectPath x y fl
+         , GeneratableMorph DB fl
+         , Morph' fl x y
+         ) => GenMorph DB x y where
+  genMorph db = repr (generateMorph db :: fl)
+  
+class Morph' fl x y where
+  repr :: fl -> x a -> y a
+  
+instance Morph' r y z => Morph' (ConnectMorph x y :+: r) x z where
+  repr (ConnectMorph m :+: r) = repr r . m
+ 
+instance (Morph' r m x, Monad m) => Morph' (IdentityMorph m :+: r) Identity x where
+  repr (IdentityMorph :+: r) = (repr r :: forall a . m a -> x a) . return . runIdentity
+  
+instance Morph' (MUMorph m :+: r) m Proxy where
+  repr (MUMorph :+: _) = const Proxy
+ 
+instance Morph' NoMorph x x where
+  repr fl = id
+  
+infixr 6 :+:
+data a :+: r = a :+: r 
+
+data NoMorph = NoMorph
+  
+type family ToMorphRepo db where
+  ToMorphRepo (cm :+: r) = TranslateConn cm ': ToMorphRepo r
+  ToMorphRepo NoMorph = '[]
+   
+type DB = ConnectMorph_2m Maybe MaybeT
+           :+: ConnectMorph_mt MaybeT 
+           :+: ConnectMorph Maybe [] 
+           :+: ConnectMorph_2m [] ListT
+           :+: ConnectMorph (MaybeT IO) (ListT IO)
+           :+: NoMorph
+ 
+db :: DB 
+db = ConnectMorph_2m (MaybeT . return) 
+       :+: ConnectMorph_mt (MaybeT . liftM Just) 
+       :+: ConnectMorph (maybeToList) 
+       :+: ConnectMorph_2m (ListT . return) 
+       :+: ConnectMorph (ListT . liftM maybeToList . runMaybeT) 
+       :+: NoMorph
+  
+-- | This class provides a way to construct the value-level transformations
+-- from the type-level path and a rulebase.
+class GeneratableMorph db ch where
+  generateMorph :: db -> ch
+    
+instance GeneratableMorph db NoMorph where
+  generateMorph _ = NoMorph
+  
+instance GeneratableMorph db r 
+      => GeneratableMorph db ((IdentityMorph m) :+: r) where
+  generateMorph db = IdentityMorph :+: generateMorph db
+  
+instance GeneratableMorph db r 
+      => GeneratableMorph db (MUMorph m :+: r) where
+  generateMorph db = MUMorph :+: generateMorph db
+  
+instance (HasMorph db (ConnectMorph a b), GeneratableMorph db r) 
+      => GeneratableMorph db (ConnectMorph a b :+: r) where
+  generateMorph db = getMorph db :+: generateMorph db
+  
+-- | This class extracts a given morph from the set of rules
+class HasMorph r m where 
+  getMorph :: r -> m
+instance {-# OVERLAPPING #-} Monad k => HasMorph (ConnectMorph_2m a b :+: r) (ConnectMorph a (b k)) where
+  getMorph (ConnectMorph_2m f :+: r) = ConnectMorph f
+instance {-# OVERLAPPING #-} Monad k => HasMorph (ConnectMorph_mt t :+: r) (ConnectMorph k (t k)) where
+  getMorph (ConnectMorph_mt f :+: r) = ConnectMorph f
+instance {-# OVERLAPS #-} HasMorph r m => HasMorph (c :+: r) m where
+  getMorph (c :+: r) = getMorph r
+instance {-# OVERLAPPABLE #-} HasMorph (m :+: r) m where
+  getMorph (c :+: r) = c
+
+-- | Checks if the path is found to provide usable error messages
+class CorrectPath from to path
+
+instance CorrectPath from to (a :+: b)
+instance CorrectPath from to NoMorph
+
+data ConnectMorph m1 m2 = ConnectMorph { fromConnectMorph :: forall a . m1 a -> m2 a }
+data ConnectMorph_2m m1 m2 = ConnectMorph_2m { fromConnectMorph_2m :: forall a k . Monad k => m1 a -> m2 k a }
+data ConnectMorph_mt mt = ConnectMorph_mt { fromConnectMorph_mt :: forall a k . Monad k => k a -> mt k a }
+data IdentityMorph (m :: * -> *) = IdentityMorph
+data MUMorph m = MUMorph
+
+-- | Transforms a path element from the generic format to the specific one
+type family TranslateConn m where
+  TranslateConn (ConnectMorph m1 m2) = Connect m1 m2
+  TranslateConn (ConnectMorph_2m m1 m2) = Connect_2m m1 m2
+  TranslateConn (ConnectMorph_mt mt) = Connect_mt mt
+  
+-- | Transforms the path from the generic format to the specific one
+type family TransformPath m where
+  TransformPath (Connect m1 m2 :+: r) = ConnectMorph m1 m2 :+: TransformPath r
+  TransformPath (Connect_id m :+: r) = IdentityMorph m :+: TransformPath r
+  TransformPath (Connect_MU m :+: r) = MUMorph m :+: TransformPath r
+  TransformPath NoMorph = NoMorph
+  TransformPath NoPathFound = NoPathFound
+  
+type family PathFromList ls where
+  PathFromList '[] = NoMorph
+  PathFromList '[ NoPathFound ] = NoPathFound
+  PathFromList (c ': ls) = c :+: PathFromList ls
+
+

@@ -0,0 +1,69 @@+{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators, MultiParamTypeClasses, FlexibleInstances, PolyKinds, UndecidableInstances, AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, FlexibleContexts #-}
+
+module Control.Instances.ShortestPath where
+
+import Control.Monad.Identity
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.List
+import Control.Monad.State
+import Data.Maybe
+import Data.Proxy
+import GHC.TypeLits
+import Control.Instances.TypeLevelPrelude
+
+-- * Generic datatypes to store connections
+  
+data Connect m1 m2
+data Connect_2m m1 m2
+data Connect_mt mt
+data Connect_id m
+data Connect_MU m
+
+-- | Marks that there is no legal path between the two types according
+-- to the rulebase.
+data NoPathFound
+  
+type family ShortestPath (e :: [*]) (s :: * -> *) (t :: * -> *) :: [*] where
+  ShortestPath e t t = '[]
+  ShortestPath e Identity t = '[ Connect_id t ]
+  ShortestPath e s Proxy = '[ Connect_MU s ]
+  ShortestPath e s t = ShortestPath' e s (InitCurrent e t)
+  
+type family ShortestPath' (e :: [*]) (s :: * -> *) (c :: [[*]]) :: [*] where
+  ShortestPath' e s '[] = '[ NoPathFound ]
+  ShortestPath' e s c = FromMaybe (ShortestPath' e s (ApplyEdges e c c))
+                                  (GetFinished s c) 
+                                  
+                                      
+type family GetFinished s c where
+  GetFinished s ((Connect s b ': p) ': lls) 
+    = Just (Connect s b ': p)
+  GetFinished s (p ': lls) = GetFinished s lls
+  GetFinished s '[] = Nothing
+
+type family InitCurrent (e :: [*]) (t :: * -> *) :: [[*]] where
+  InitCurrent '[] t = '[]
+  InitCurrent (e ': es) t = IfJust (ApplyEdge e t)
+                                   ('[ MonomorphEnd e t ] ': InitCurrent es t) 
+                                   (InitCurrent es t)
+  
+type family ApplyEdges (e :: [*]) (co :: [[*]]) (c :: [[*]]) :: [[*]] where
+  ApplyEdges (e ': es) co ((Connect s b ': p) ': cs) 
+    = AppendJust (IfThenJust (IsJust (ApplyEdge e s)) 
+                                (MonomorphEnd e s ': Connect s b ': p)) 
+                 (ApplyEdges (e ': es) co cs)
+  ApplyEdges (e ': es) co '[] = ApplyEdges es co co
+  ApplyEdges '[] co cr = '[]  
+  
+type family ApplyEdge e t :: Maybe (* -> *) where
+  ApplyEdge (Connect ms mr) mr = Just ms
+  ApplyEdge (Connect_2m ms mt) (mt m) = Just ms
+  ApplyEdge (Connect_mt mt) (mt m) = Just m
+  ApplyEdge e t = Nothing
+
+type family MonomorphEnd c v :: * where
+  MonomorphEnd (Connect_2m m m') v = Connect m v
+  MonomorphEnd (Connect_mt t) (t m) = Connect m (t m)
+  MonomorphEnd c v = c
+
+

@@ -0,0 +1,23 @@+module Control.Instances.Test where
+
+import Control.Instances.Morph
+
+import Control.Monad.Identity
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.List
+import Control.Monad.State
+
+test1 :: Identity a -> IO a
+test1 = morph
+
+test2 :: Maybe a -> [a]
+test2 = morph
+
+test3 :: Maybe a -> ListT IO a
+test3 = morph
+
+test4 :: Maybe a -> MaybeT IO a
+test4 = morph
+
+test5 :: Monad m => Maybe a -> ListT (StateT s m) a
+test5 = morph

@@ -0,0 +1,88 @@+{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators, MultiParamTypeClasses, FlexibleInstances, PolyKinds, UndecidableInstances, AllowAmbiguousTypes, RankNTypes, ScopedTypeVariables, FlexibleContexts #-}
+
+module Control.Instances.TypeLevelPrelude where
+
+import GHC.TypeLits
+
+type family Const a b where
+  Const a b = a
+  
+type family Seq a b where
+  Seq a b = b
+  
+type family LazyIfThenElse p a b where
+  LazyIfThenElse True a b = a
+  LazyIfThenElse False a b = b
+  
+type family Iterate a where
+  Iterate a = a ': Iterate a
+
+type family l1 :++: l2 where
+  '[] :++: l2       = l2
+  (e ': r1) :++: l2 = e ': (r1 :++: l2)
+  
+type family Elem e ls where
+  Elem e '[] = False
+  Elem e (e ': ls) = True
+  Elem e (x ': ls) = Elem e ls
+  
+type family IfThenElse (b :: Bool) (th :: x) (el :: x) :: x where
+  IfThenElse True  th el = th
+  IfThenElse False th el = el
+         
+type family Length ls :: Nat where
+  Length '[] = 0
+  Length (e ': ls) = 1 + Length ls
+           
+type family Head (ls :: [k]) :: k where
+  Head (e ': ls) = e   
+  
+type family HeadMaybe (ls :: [k]) :: Maybe k where
+  HeadMaybe (e ': ls) = Just e
+  HeadMaybe '[] = Nothing
+  
+type family FromMaybe d m where
+  FromMaybe d (Just x) = x
+  FromMaybe d Nothing = d
+  
+type family Same a b where
+  Same a a = True
+  Same a b = False
+  
+type family Null (ls :: [k]) :: Bool where
+  Null '[] = True
+  Null ls = False
+           
+type family MapAppend e lls where
+  MapAppend e (ls ': lls) = (e ': ls) ': MapAppend e lls
+  MapAppend e '[] = '[]
+  
+type family AppendJust m ls where
+  AppendJust (Just x) ls = x ': ls
+  AppendJust Nothing ls = ls
+  
+type family Revert ls where
+  Revert '[] = '[]
+  Revert (e ': ls) = Revert ls :++: '[ e ]
+  
+type family IfThenJust (p :: Bool) (v :: k) :: Maybe k where
+  IfThenJust True v = Just v
+  IfThenJust False v = Nothing  
+  
+type family IfJust (p :: Maybe k) (t :: kr) (e :: kr) :: kr where
+  IfJust (Just x) t e = t
+  IfJust Nothing t e = e
+  
+type family IsJust (p :: Maybe k) :: Bool where
+  IsJust (Just x) = True
+  IsJust Nothing = False    
+  
+type family FromJust (p :: Maybe k) :: k where
+  FromJust (Just x) = x
+  
+type family Cat (f2 :: k2 -> k3) (f1 :: k1 -> k2) (a :: k1) :: k3 where
+  Cat f2 f1 a = f2 (f1 a)
+  
+
+  
+  

@@ -0,0 +1,1 @@+module Module.DeprecatedPragma {-# DEPRECATED "this module is deprecated" #-} where

@@ -0,0 +1,2 @@+module Module.Export (maybe, Maybe(..), Either(Left)) where
+-- this module reexports Maybe from Prelude

@@ -0,0 +1,4 @@+{-# LANGUAGE ExplicitNamespaces, PatternSynonyms #-}
+module Module.ExportModifiers (type Maybe, pattern Maybe) where
+
+pattern Maybe = 42

@@ -0,0 +1,3 @@+module Module.ExportSubs (T(Cons, name)) where
+
+data T = Cons { name :: String }

@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+module Module.GhcOptionsPragma where

@@ -0,0 +1,11 @@+{-# LANGUAGE PackageImports, Safe #-}
+module Module.Import where
+
+import Data.List
+import "base" Data.List
+import {-# SOURCE #-} Data.List
+import qualified Data.List
+import Data.List as List
+import Data.List(map,(++))
+import Data.Function hiding ((&))
+import safe Control.Monad.Writer hiding (Alt, Writer())

@@ -0,0 +1,3 @@+module Module.ImportOp where
+
+import Module.Imported ((:-)(..))

@@ -0,0 +1,6 @@+{-# LANGUAGE TypeOperators #-}
+module Module.Imported where
+
+infixr 8 :-
+-- | A stack datatype. Just a better looking tuple.
+data a :- b = a :- b deriving (Eq, Show)

@@ -0,0 +1,4 @@+{-# LANGUAGE LambdaCase #-}
+{-#LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase#-}
+module Module.LangPragmas where

@@ -0,0 +1,4 @@+{-# LANGUAGE TypeOperators #-}
+module Module.NamespaceExport (type (++)) where
+
+data a ++ b = Ctor

@@ -0,0 +1,4 @@+{-# LANGUAGE PatternSynonyms #-}
+module Module.PatternImport where
+
+import Decl.PatternSynonym (pattern Arrow)

@@ -0,0 +1,1 @@+module Module.Simple where

@@ -0,0 +1,1 @@+module Module.WarningPragma {-# WARNING "this module is dangerous" #-} where

@@ -0,0 +1,5 @@+module Pattern.Backtick where
+
+data Point = Point { x :: Prelude.Int, y :: Int }
+
+f (x `Point` y) = 0

@@ -0,0 +1,3 @@+module Pattern.Constructor where
+
+Just x = Just 1

@@ -0,0 +1,9 @@+{-# LANGUAGE ImplicitParams #-}
+module Pattern.ImplicitParams where
+
+import Data.List (sortBy)
+
+sort :: (?cmp :: a -> a -> Ordering) => [a] -> [a]
+sort = sortBy ?cmp
+
+main = let ?cmp = compare in putStrLn (show (sort [3,1,2]))

@@ -0,0 +1,5 @@+module Pattern.Infix where
+
+--(a:b:c:d) = ["1","2","3","4"]
+
+Nothing:_ = undefined

@@ -0,0 +1,6 @@+{-# LANGUAGE NPlusKPatterns #-}
+module Pattern.NPlusK where
+
+factorial :: Integer -> Integer
+factorial 0 = 1
+factorial (n+1) = (*) (n+1) (factorial n)

@@ -0,0 +1,7 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
+module Pattern.NestedWildcard where
+
+data A = A { b :: B, ai :: Int }
+data B = B { bi :: Int }
+
+h A { b = B {..}, .. } = bi + ai

@@ -0,0 +1,3 @@+module Pattern.OperatorPattern where
+
+child r (_:ps) = r ps

@@ -0,0 +1,11 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
+module Pattern.Record where
+
+data Point = Point { x :: Int, y :: Int }
+
+f Point { x = 3, y = 1 } = 0
+f Point {} = 1
+
+g Point { x } = x
+
+h Point { x = 1, .. } = y

@@ -0,0 +1,6 @@+{-# LANGUAGE UnboxedSums #-}
+module Pattern.UnboxedSum where
+
+f :: (# Int | Bool #) -> ()
+f (# i | #) = ()
+f (# | b #) = ()

@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.Brackets where
+
+import Language.Haskell.TH
+
+decls :: Q [Dec]
+decls = [d| w = 3 |]
+
+exp :: Q Exp
+exp = [| 3 |]
+
+exp' :: Q Exp
+exp' = [e| 3 |]
+
+pat :: Q Pat
+pat = [p| x |]
+
+typ :: Q Type
+typ = [t| Int |]

@@ -0,0 +1,10 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}
+module TH.ClassUse where
+
+class C a where
+  f :: a -> a
+
+$([d|
+    instance C a where
+     f = id
+ |])

@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.CrossDef where
+
+$([d| x = 3 |])

@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.DoubleSplice where
+
+$($(id [| return [] |]))

@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs, KindSignatures, TypeFamilies, TemplateHaskell #-}
+module TH.GADTFields where
+
+data Gadtrec1 a where
+  Gadtrecc1, Gadtrecc2 :: { gadtrec1a :: a, gadtrec1b :: b } -> Gadtrec1 (a,b)
+
+$( let a = ['gadtrec1a, 'gadtrec1b] in return [] )

@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.LocalDefinition where
+
+import Language.Haskell.TH
+
+decls :: Q [Dec]
+decls = [d| w = 3 |]
+
+exp :: Q Exp
+exp = [| 3 |]
+
+exp' :: Q Exp
+exp' = [e| 3 |]
+
+pat :: Q Pat
+pat = [p| x |]
+
+typ :: Q Type
+typ = [t| Int |]

@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.MultiImport where
+
+import Prelude (last,return)
+import qualified Data.Text (last)
+
+$(let f = last in return [])

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.NestedSplices where
+
+import Language.Haskell.TH
+
+f = [t| $(parensT [t| $(return ListT) |]) |]

@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}
+module TH.QuasiQuote.Define where
+
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH
+
+expr :: QuasiQuoter
+expr = QuasiQuoter { quoteExp = const (return $ VarE $ mkName "hello") }

@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}
+{-# LANGUAGE QuasiQuotes #-}
+module TH.QuasiQuote.Use where
+
+import TH.QuasiQuote.Define
+
+hello :: Int
+hello = 3
+
+main :: IO ()
+main = print [expr| 1 + 2 + 4|]

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.Quoted where
+
+import qualified Text.Read.Lex (Lexeme)
+
+$(let x = ''Text.Read.Lex.Lexeme in return [])

@@ -0,0 +1,24 @@+module TH.Splice.Define where
+
+import Language.Haskell.TH
+
+def :: String -> Q [Dec]
+def name = return [ ValD (VarP (mkName name)) (NormalB $ LitE $ IntegerL 3) [] ]
+
+defHello :: Q [Dec]
+defHello = def "hello"
+
+defHello2 :: Q [Dec]
+defHello2 = def "hello2"
+
+defHello3 :: Q [Dec]
+defHello3 = def "hello3"
+
+expr :: Q Exp
+expr = return $ LitE $ IntegerL 3
+
+typ :: Q Type
+typ = return $ TupleT 0
+
+nameOf :: Name -> Q [Dec]
+nameOf n = return []

@@ -0,0 +1,12 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.Splice.Names where
+
+import TH.Splice.Define
+
+data A = A
+
+$(nameOf ''A)
+nameOf ''A
+
+$(nameOf 'A)
+nameOf 'A

@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.Splice.Use where
+
+import TH.Splice.Define
+
+$(return [])
+
+$(let x = return [] in x)
+
+$(def "x")
+
+$(defHello)
+
+$defHello2
+
+defHello3
+
+a :: $typ
+a = ()
+
+e :: Int
+e = $expr

@@ -0,0 +1,9 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.Splice.UseImported where
+
+data T a = T a
+
+$([d|
+  instance Show a => Show (T a) where show = undefined
+  instance (Eq a, Show a) => Eq (T a) where (==) = undefined
+  |])

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.Splice.UseQual where
+
+import qualified TH.Splice.Define as Def
+
+$(Def.def "x")

@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}
+module TH.Splice.UseQualMulti where
+
+import qualified TH.Splice.Define as Def
+import qualified TH.Splice.Define as Def2
+
+$(Def.def "x")
+$(Def2.def "y")

@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell, RecordWildCards #-}
+module TH.WithWildcards where
+
+import Language.Haskell.TH.Syntax
+
+data A = A { x :: Q Exp }
+
+g A{..} = [| $(x) |]

@@ -0,0 +1,4 @@+module Type.Bang where
+
+data X = X !Int
+

@@ -0,0 +1,20 @@+{-# LANGUAGE MagicHash #-}
+module Type.Builtin where
+
+import GHC.Prim 
+import GHC.Base
+
+x1 :: IO ()
+x1 = undefined
+
+x2 :: IO Int
+x2 = return 2
+
+x3 :: Int
+x3 = I# x3'
+  where x3' :: Int#
+        x3' = 3#
+
+x4 :: (Int, Bool)
+x4 = (3,True)
+

@@ -0,0 +1,10 @@+module Type.Ctx where
+
+sh :: Show a => a -> String
+sh = show
+
+sh' :: (Show a) => a -> String
+sh' = show
+
+sh'' :: (Show a, Eq a) => a -> String
+sh'' = show

@@ -0,0 +1,7 @@+{-# LANGUAGE TypeApplications #-}
+module Type.ExplicitTypeApplication where
+
+quad :: a -> b -> c -> d -> (a, b, c, d)
+quad w x y z = (w, x, y, z)
+
+foo = quad @Bool @_ @Int False 'c' 17 "Hello!"

@@ -0,0 +1,11 @@+{-# LANGUAGE ScopedTypeVariables #-}
+module Type.Forall where
+
+id :: forall a . a -> a
+id x = x
+
+id' :: a -> a
+id' x = x
+
+id'' :: forall a . Monoid a => a -> a
+id'' x = x

@@ -0,0 +1,10 @@+{-# LANGUAGE MagicHash #-}
+module Type.Primitives where
+import GHC.Prim
+
+data MyInt = MyInt Int#
+
+my3 = MyInt 3#
+
+myPlus :: MyInt -> MyInt -> MyInt
+myPlus (MyInt i) (MyInt j) = MyInt (i +# j)

@@ -0,0 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}
+module Type.TupleAssert where
+
+f :: (Ord a, (Show a, Eq a)) => a -> String
+f = show

@@ -0,0 +1,10 @@+{-# LANGUAGE TypeOperators #-}
+module Type.TypeOperators where
+
+infixr 6 :+:
+data a :+: r = a :+: r 
+
+type X = Int :+: Char :+: String
+
+type (:&:) = (,)
+infixr :&:

@@ -0,0 +1,4 @@+module Type.Unpack where
+
+data X = X {-# UNPACK #-} !Int {-# NOUNPACK #-} !Int 
+

@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+module Type.Wildcard where
+
+not' :: Bool -> _
+not' x = not x
+-- Inferred: Bool -> Bool

@@ -1,5 +1,5 @@ name:                haskell-tools-refactor
-version:             1.0.0.4
+version:             1.0.1.1
 synopsis:            Refactoring Tool for Haskell
 description:         Contains a set of refactorings based on the Haskell-Tools framework to easily transform a Haskell program. For the descriptions of the implemented refactorings, see the homepage.
 homepage:            https://github.com/haskell-tools/haskell-tools
@@ -11,23 +11,44 @@ build-type:          Simple
 cabal-version:       >=1.10
 
+extra-source-files: examples/CppHs/Language/Preprocessor/*.hs
+                  , examples/CppHs/Language/Preprocessor/Cpphs/*.hs
+                  , examples/CppHs/Language/Preprocessor/Cpphs/*.hs
+                  , examples/Decl/*.hs
+                  , examples/Expr/*.hs
+                  , examples/InstanceControl/Control/Instances/*.hs
+                  , examples/Module/*.hs
+                  , examples/Pattern/*.hs
+                  , examples/TH/*.hs
+                  , examples/CPP/*.hs
+                  , examples/TH/QuasiQuote/*.hs
+                  , examples/TH/Splice/*.hs
+                  , examples/Type/*.hs
+                  , examples/CommentHandling/*.hs
+
 library
   ghc-options: -O2
   exposed-modules:     Language.Haskell.Tools.Refactor
-                     , Language.Haskell.Tools.Refactor.Utils.BindingElem
-                     , Language.Haskell.Tools.Refactor.Utils.Monadic
                      , Language.Haskell.Tools.Refactor.Monad
-                     , Language.Haskell.Tools.Refactor.Representation
                      , Language.Haskell.Tools.Refactor.Prepare
-                     , Language.Haskell.Tools.Refactor.Utils.Lists
-                     , Language.Haskell.Tools.Refactor.Utils.Name
-                     , Language.Haskell.Tools.Refactor.Utils.Helpers
-                     , Language.Haskell.Tools.Refactor.Utils.AST
                      , Language.Haskell.Tools.Refactor.Refactoring
-                     , Language.Haskell.Tools.Refactor.Utils.Indentation
+                     , Language.Haskell.Tools.Refactor.Representation
+                     , Language.Haskell.Tools.Refactor.Utils.AST
+                     , Language.Haskell.Tools.Refactor.Utils.BindingElem
                      , Language.Haskell.Tools.Refactor.Utils.Extensions
+                     , Language.Haskell.Tools.Refactor.Utils.Helpers
+                     , Language.Haskell.Tools.Refactor.Utils.Indentation
+                     , Language.Haskell.Tools.Refactor.Utils.Lists
+                     , Language.Haskell.Tools.Refactor.Utils.Maybe
+                     , Language.Haskell.Tools.Refactor.Utils.Monadic
+                     , Language.Haskell.Tools.Refactor.Utils.Name
+                     , Language.Haskell.Tools.Refactor.Utils.Type
+                     , Language.Haskell.Tools.Refactor.Utils.NameLookup
+                     , Language.Haskell.Tools.Refactor.Utils.TypeLookup
+                     , Language.Haskell.Tools.Refactor.Querying
 
-  build-depends:       base                      >= 4.10  && < 4.11
+  build-depends:       base                      >= 4.10 && < 4.11
+                     , aeson                     >= 1.0  && < 1.4
                      , mtl                       >= 2.2  && < 2.3
                      , uniplate                  >= 1.6  && < 1.7
                      , ghc-paths                 >= 0.1  && < 0.2
@@ -39,9 +60,41 @@                      , filepath                  >= 1.4  && < 1.5
                      , template-haskell          >= 2.12 && < 2.13
                      , ghc                       >= 8.2  && < 8.3
-                     , Cabal                     >= 2.0 && < 2.1
+                     , Cabal                     >= 2.0  && < 2.3
                      , haskell-tools-ast         >= 1.0  && < 1.1
                      , haskell-tools-backend-ghc >= 1.0  && < 1.1
                      , haskell-tools-rewrite     >= 1.0  && < 1.1
                      , haskell-tools-prettyprint >= 1.0  && < 1.1
+  default-language:    Haskell2010
+
+test-suite haskell-tools-builtin-refactorings-test
+  type:                exitcode-stdio-1.0
+  ghc-options:         -with-rtsopts=-M2g
+  hs-source-dirs:      test
+  main-is:             Main.hs
+  build-depends:       base                      >= 4.10 && < 4.11
+                     , tasty                     >= 0.11 && < 0.12
+                     , tasty-hunit               >= 0.9  && < 0.10
+                     , transformers              >= 0.5  && < 0.6
+                     , either                    >= 4.4  && < 4.6
+                     , filepath                  >= 1.4  && < 1.5
+                     , mtl                       >= 2.2  && < 2.3
+                     , uniplate                  >= 1.6  && < 1.7
+                     , containers                >= 0.5  && < 0.6
+                     , directory                 >= 1.2  && < 1.4
+                     , references                >= 0.3  && < 0.4
+                     , split                     >= 0.2  && < 0.3
+                     , time                      >= 1.8  && < 1.9
+                     , template-haskell          >= 2.12 && < 2.13
+                     , ghc                       >= 8.2  && < 8.3
+                     , ghc-paths                 >= 0.1  && < 0.2
+                     , Cabal                     >= 2.0  && < 2.3
+                     , haskell-tools-ast         >= 1.0  && < 1.1
+                     , haskell-tools-backend-ghc >= 1.0  && < 1.1
+                     , haskell-tools-rewrite     >= 1.0  && < 1.1
+                     , haskell-tools-prettyprint >= 1.0  && < 1.1
+                     , haskell-tools-refactor
+                     -- libraries used by the examples
+                     , old-time                  >= 1.1  && < 1.2
+                     , polyparse                 >= 1.12 && < 1.13
   default-language:    Haskell2010

@@ -0,0 +1,196 @@+{-# LANGUAGE LambdaCase, MonoLocalBinds #-}
+
+           
+module Main where
+
+import Test.Tasty (TestTree, testGroup, defaultMain)
+import Test.Tasty.HUnit
+
+import GHC hiding (loadModule, ParsedModule)
+import GHC.Paths ( libdir )
+
+import System.FilePath
+import System.IO
+
+import Language.Haskell.Tools.PrettyPrint (prettyPrint)
+import Language.Haskell.Tools.Refactor
+
+main :: IO ()
+main = defaultMain nightlyTests
+
+nightlyTests :: TestTree
+nightlyTests
+  = testGroup "all tests" [ testGroup "reprint tests" (map makeReprintTest languageTests)
+                          , testGroup "CppHs tests" $ map makeCpphsTest cppHsTests
+                          , testGroup "instance-control tests" $ map makeInstanceControlTest instanceControlTests
+                          ]
+
+makeReprintTest :: String -> TestTree
+makeReprintTest mod = testCase mod (checkCorrectlyPrinted rootDir mod)
+
+makeCpphsTest :: String -> TestTree
+makeCpphsTest mod = testCase mod (checkCorrectlyPrinted (rootDir </> "CppHs") mod)
+
+makeInstanceControlTest :: String -> TestTree
+makeInstanceControlTest mod = testCase mod (checkCorrectlyPrinted (rootDir </> "InstanceControl") mod)
+
+checkCorrectlyPrinted :: String -> String -> IO ()
+checkCorrectlyPrinted workingDir moduleName
+  = do -- need to use binary or line endings will be translated
+       expectedHandle <- openBinaryFile (workingDir </> map (\case '.' -> pathSeparator; c -> c) moduleName ++ ".hs") ReadMode
+       expected <- hGetContents expectedHandle
+       actual <- runGhc (Just libdir) $ do
+         parsed <- loadModule workingDir moduleName
+         prettyPrint <$> parseTyped parsed
+       assertEqual "The original and the transformed source differ" expected actual
+
+
+rootDir = "examples"
+
+cppHsTests =
+  [ "Language.Preprocessor.Cpphs"
+  , "Language.Preprocessor.Unlit"
+  , "Language.Preprocessor.Cpphs.CppIfdef"
+  , "Language.Preprocessor.Cpphs.HashDefine"
+  , "Language.Preprocessor.Cpphs.MacroPass"
+  , "Language.Preprocessor.Cpphs.Options"
+  , "Language.Preprocessor.Cpphs.Position"
+  , "Language.Preprocessor.Cpphs.ReadFirst"
+  , "Language.Preprocessor.Cpphs.RunCpphs"
+  , "Language.Preprocessor.Cpphs.SymTab"
+  , "Language.Preprocessor.Cpphs.Tokenise"
+  ]
+
+instanceControlTests =
+  [ "Control.Instances.Test"
+  , "Control.Instances.Morph"
+  , "Control.Instances.ShortestPath"
+  , "Control.Instances.TypeLevelPrelude"
+  ]
+
+languageTests =
+  [ "CPP.JustEnabled"
+  , "CPP.ConditionalCode"
+  , "Decl.AmbiguousFields"
+  , "Decl.AnnPragma"
+  , "Decl.ClassInfix"
+  , "Decl.ClosedTypeFamily"
+  , "Decl.CompletePragma"
+  , "Decl.CtorOp"
+  , "Decl.DataFamily"
+  , "Decl.DataType"
+  , "Decl.DataInstanceGADT"
+  , "Decl.DataTypeDerivings"
+  , "Decl.DefaultDecl"
+  , "Decl.FunBind"
+  , "Decl.FunctionalDeps"
+  , "Decl.FunGuards"
+  , "Decl.GADT"
+  , "Decl.GadtConWithCtx"
+  , "Decl.InfixAssertion"
+  , "Decl.InfixInstances"
+  , "Decl.InfixPatSyn"
+  , "Decl.InjectiveTypeFamily"
+  , "Decl.InlinePragma"
+  , "Decl.InstanceFamily"
+  , "Decl.InstanceOverlaps"
+  , "Decl.InstanceSpec"
+  , "Decl.LocalBindings"
+  , "Decl.LocalBindingInDo"
+  , "Decl.LocalFixity"
+  , "Decl.MinimalPragma"
+  , "Decl.MultipleFixity"
+  , "Decl.MultipleSigs"
+  , "Decl.OperatorBind"
+  , "Decl.OperatorDecl"
+  , "Decl.ParamDataType"
+  , "Decl.PatternBind"
+  , "Decl.PatternSynonym"
+  , "Decl.RecordPatternSynonyms"
+  , "Decl.RecordType"
+  , "Decl.RewriteRule"
+  , "Decl.SpecializePragma"
+  , "Decl.StandaloneDeriving"
+  , "Decl.TypeClass"
+  , "Decl.TypeClassMinimal"
+  , "Decl.TypeFamily"
+  , "Decl.TypeFamilyKindSig"
+  , "Decl.TypeInstance"
+  , "Decl.TypeRole"
+  , "Decl.TypeSynonym"
+  , "Decl.ValBind"
+  , "Decl.ViewPatternSynonym"
+  , "Expr.ArrowNotation"
+  , "Expr.Case"
+  , "Expr.DoNotation"
+  , "Expr.GeneralizedListComp"
+  , "Expr.EmptyCase"
+  , "Expr.FunSection"
+  , "Expr.If"
+  , "Expr.LambdaCase"
+  , "Expr.ListComp"
+  , "Expr.MultiwayIf"
+  , "Expr.Negate"
+  , "Expr.Operator"
+  , "Expr.ParenName"
+  , "Expr.ParListComp"
+  , "Expr.PatternAndDo"
+  , "Expr.RecordPuns"
+  , "Expr.RecordWildcards"
+  , "Expr.RecursiveDo"
+  , "Expr.Sections"
+  , "Expr.SemicolonDo"
+  , "Expr.StaticPtr"
+  , "Expr.TupleSections"
+  , "Expr.UnboxedSum"
+  , "Module.Simple"
+  , "Module.GhcOptionsPragma"
+  , "Module.Export"
+  , "Module.ExportSubs"
+  , "Module.ExportModifiers"
+  , "Module.NamespaceExport"
+  , "Module.Import"
+  , "Module.ImportOp"
+  , "Module.LangPragmas"
+  , "Module.PatternImport"
+  , "Pattern.Backtick"
+  , "Pattern.Constructor"
+  -- , "Pattern.ImplicitParams"
+  , "Pattern.Infix"
+  , "Pattern.NestedWildcard"
+  , "Pattern.NPlusK"
+  , "Pattern.OperatorPattern"
+  , "Pattern.Record"
+  , "Pattern.UnboxedSum"
+  , "Type.Bang"
+  , "Type.Builtin"
+  , "Type.Ctx"
+  , "Type.ExplicitTypeApplication"
+  , "Type.Forall"
+  , "Type.Primitives"
+  , "Type.TupleAssert"
+  , "Type.TypeOperators"
+  , "Type.Unpack"
+  , "Type.Wildcard"
+  , "TH.Brackets"
+  , "TH.QuasiQuote.Define"
+  , "TH.QuasiQuote.Use"
+  , "TH.Splice.Define"
+  , "TH.Splice.Use"
+  , "TH.CrossDef"
+  , "TH.ClassUse"
+  , "TH.Splice.UseImported"
+  , "TH.Splice.UseQual"
+  , "TH.Splice.UseQualMulti"
+  , "TH.LocalDefinition"
+  , "TH.MultiImport"
+  , "TH.NestedSplices"
+  , "TH.Quoted"
+  , "TH.WithWildcards"
+  , "TH.DoubleSplice"
+  , "TH.GADTFields"
+  , "CommentHandling.CommentTypes"
+  , "CommentHandling.BlockComments"
+  , "CommentHandling.Crosslinking"
+  , "CommentHandling.FunctionArgs"
+  ]