Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
187 lines (168 sloc) 5.3 KB
module Main where
import Text.Parsec
import Data.Char
import Control.Applicative ((<*))
import Control.Monad (guard)
import Control.Lens
import Data.Maybe
import Data.Traversable
import Data.Foldable
import Data.List (isInfixOf, dropWhileEnd)
import System.Environment
import Language.Haskell.Exts
import System.Process
import Prelude hiding (concatMap, mapM, mapM_, concat, elem, notElem)
import Debug.Trace
imports =
[ "Control.Applicative"
, "Control.Applicative.Backwards (Backwards)"
, "Control.Exception"
, "Data.Typeable (Typeable)"
, "Data.Dynamic (Dynamic)"
, "Data.Dynamic.Lens"
, "Data.Hashable (Hashable)"
, "Data.HashSet (HashSet)"
, "Data.Typeable.Lens"
, "Control.Lens"
, "Control.Lens.Internal"
, "Control.Monad.RWS"
, "Control.Monad.Reader"
, "Control.Monad.State"
, "Control.Monad.Trans.Error (Error,ErrorT)"
, "Control.Monad.Writer"
, "Data.Foldable (Foldable)"
, "Data.ByteString.Lens"
, "Data.Sequence (Seq)"
, "Data.Vector (Vector)"
, "Data.Void (Void)"
, "Data.Word (Word8)"
, "Data.Bits (Bits)"
, "Data.Bits.Lens"
, "Data.ByteString (ByteString)"
, "Data.Set (Set)"
, "Data.IntSet (IntSet)"
, "Data.List.Split"
, "Data.List.Split.Lens"
, "Data.Set.Lens"
, "qualified Control.Lens.Cons"
, "qualified Control.Lens.Fold"
, "qualified Control.Lens.Getter"
, "qualified Control.Lens.Internal.Indexed"
, "qualified Control.Lens.Iso"
, "qualified Control.Lens.Prism"
, "qualified Control.Lens.Setter"
, "qualified Control.Lens.Traversal"
, "qualified Control.Lens.Tuple"
, "qualified Data.ByteString as StrictB"
, "qualified Data.ByteString.Lazy as LazyB"
, "qualified Data.ByteString.Lazy"
, "qualified Data.Complex"
, "Data.Complex (Complex)"
, "Data.Array (Array, Ix)"
, "Data.Map (Map)"
, "Data.Functor.Identity (Identity)"
, "qualified Data.Vector as Vector"
, "qualified Data.Vector.Unboxed as Unboxed"
, "qualified Data.Vector.Storable as Storable"
, "Data.Vector.Primitive (Prim)"
, "qualified Data.Vector.Primitive as Prim"
, "Data.HashMap.Lazy (HashMap)"
, "Data.Tree (Tree)"
, "Foreign.Storable (Storable)"
, "Data.Int (Int64)"
, "qualified Data.Complex.Lens"
, "qualified Data.List.Lens"
, "qualified Data.Monoid"
, "qualified Data.Text as StrictT"
, "qualified Data.Text.Lazy as LazyT"
, "qualified Data.Text"
, "qualified Data.Text.Internal"
, "qualified Data.Traversable"
, "qualified Numeric.Natural"
, "Data.Vector.Unboxed (Unbox)"
]
usedExtensions =
[ "Rank2Types"
, "FlexibleContexts"
]
valueBlacklist =
[ "nat"
, "fresh"
, "singular"
, "unsafeSingular"
, "dropping"
, "droppingWhile"
, "idroppingWhile"
, "taking"
, "takingWhile"
, "itakingWhile"
]
fileBlacklist =
[ "src/Control/Lens/TH.hs"
]
myParserMode = defaultParseMode
{ extensions = glasgowExts
, fixities = Just
$ preludeFixities
++ [Fixity AssocRight 9 (UnQual (Symbol "#."))
,Fixity AssocLeft 8 (UnQual (Symbol ".#"))
,Fixity AssocLeft 4 (UnQual (Symbol "<$"))
,Fixity AssocLeft 4 (UnQual (Symbol "<$>"))
,Fixity AssocLeft 4 (UnQual (Symbol "<*>"))
]
}
processCpp = readProcess "cpp" ["-P","-include","dist/build/autogen/cabal_macros.h","-DHLINT"]
main :: IO ()
main = do
fns <- getArgs
let fns' = filter (`notElem` fileBlacklist) fns
ms <- for fns' $ \fn -> do
txt <- readFile fn
nocpp <- processCpp txt
case parseModuleWithComments myParserMode {parseFilename = fn} nocpp of
ParseFailed srcloc err -> fail (fn ++ ": " ++ show srcloc ++ ": " ++ err)
ParseOk (_m,comments) -> return comments
putStr $ unlines $
map (\x -> "{-# LANGUAGE " ++ x ++ " #-}") usedExtensions
++ map ("import " ++) imports
++ iconcatMap (\i -> render i . asType) (concat ms)
asType (Comment _ _ str)
| "::" `isInfixOf` str =
case cleanQuotes True (filterAts str) of
Nothing -> error ("!"++str)
Just clean -> case parseExp clean of
ParseFailed _ err -> Left (str ++ " : " ++ err)
ParseOk (ExpTypeSig _ e t) -> Right (e,t)
ParseOk _ -> Left str
| otherwise = Left str
render _ (Left s) = []
render i (Right (l,r)) | prettyPrint l `elem` valueBlacklist = []
render i (Right (l,r)) =
[ "check_" ++ show i ++ " :: " ++ prettyPrint r
, "check_" ++ show i ++ args ++ " = " ++ prettyPrint (Paren l) ++ args
]
where
arity = typeArity r
args = concatMap (\x -> [' ',x]) (take arity ['a'..'z'])
typeArity (TyForall _ _ x) = typeArity x
typeArity (TyFun _ x) = 1 + typeArity x
typeArity _ = 0
cleanQuotes True ('\'':xs) = quotedPart xs
cleanQuotes False ('\'':xs) = fmap ('\'':) (cleanQuotes False xs)
cleanQuotes _ (x:xs) = fmap (x:) (cleanQuotes (isEligible x) xs)
cleanQuotes _ [] = Just []
isEligible '(' = True
isEligible '[' = True
isEligible ' ' = True
isEligible _ = False
quotedPart ('\'':'\'':xs) = fmap ('\'':) (cleanQuotes False xs)
quotedPart ('\'':xs) = cleanQuotes False xs
quotedPart (x:xs)
| isEndEligible x = Nothing
| otherwise = fmap (x:) (quotedPart xs)
quotedPart [] = Nothing
isEndEligible ')' = True
isEndEligible ']' = True
isEndEligible ' ' = True
isEndEligible _ = False
filterAts = dropWhileEnd (=='@') . dropWhileEnd isSpace . dropWhile (=='@') . dropWhile isSpace . dropWhile (=='|') . dropWhile isSpace
Jump to Line
Something went wrong with that request. Please try again.