Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'rewrite'

  • Loading branch information...
commit 3be8db015221cf845fc88192d21861a700c86dbf 2 parents 4816e3e + bc71412
@spockz spockz authored
Showing with 110 additions and 137 deletions.
  1. +24 −9 README.asciidoc
  2. +84 −127 src/Literate/Haskell.hs
  3. +2 −1  src/Literate/SimpleInfo.hs
View
33 README.asciidoc
@@ -85,18 +85,33 @@ For your convenience there are some automatic rewrites being done.
* If a identifier names in a sequence of digits, the digits will be
typeset in subscript.
-* If you have trailing underscores they will be omitted in the typesetting.
- This is so you can do something like:
-
- -----
- data Foo = Foo_ a;
- -----
-
+* If you have trailing underscores they will be omitted in the typesetting. This
+ is so you can do something like in <<Automatic_underscore_removal, Automatic
+ removal of trailing underscores>>.
And have Foo highlighted as a type constructor, and Foo_ highlighted as
`Foo' in a data constructor colour.
-* If there are underscores in the middle of your identifier, everything
- after the underscores will be typeset in subscript.
+* If there are underscores in the middle of your identifier, everything after
+ the underscores will be typeset in subscript as in
+ <<Automatic_subscript_generation, Automatic subscript generation>>.
+
+.Automatic removal of trailing underscores
+[[Automatic_underscore_removal]]
+[source,haskell]
+-----
+data Foo = Foo_ a;
+-----
+
+.Automatic subscript generation
+[[Automatic_subscript_generation]]
+[source,haskell]
+----
+foo_1 = undefined
+-- Get's transformed into
+foo₁ = undefined
+----
+
+
THEMES
------
View
211 src/Literate/Haskell.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NamedFieldPuns #-}
-module Literate.Haskell (runHaskell, mapping, listClasses, fromParse) where
+{-# LANGUAGE RankNTypes #-}
+module Literate.Haskell (runHaskell, mapping, fromParse) where
import Data.List (nub)
import Data.Maybe
@@ -14,6 +15,13 @@ import Literate.SimpleInfo
newtype M = M Module deriving (Typeable, Data)
+type ItemQuery a = a -> [Item]
+
+newtype ConstructorSearch = ConstructorSearch Module deriving (Typeable, Show)
+newtype FunctionSearch = FunctionSearch Module deriving (Typeable, Show)
+newtype OperatorSearch = OperatorSearch Module deriving (Typeable, Show)
+newtype ClassSearch = ClassSearch Module deriving (Typeable, Show)
+
parseFile fp = parseFileWithMode (defaultParseMode { fixities = Just baseFixities
, parseFilename = fp
}
@@ -28,93 +36,89 @@ runHaskell fp = do mod <- parseFile fp
"Parsing failed at `"
++ show loc
++ " " ++ err
+
+
+collect :: Module -> [Item]
+collect = nub . everything (++) ([] `mkQ` searchTypes
+ `extQ` searchConDecl
+ `extQ` searchPat
+ `extQ` searchExp
+ `extQ` searchMat
+ `extQ` searchDecl
+ `extQ` searchDeriving
+ `extQ` searchAsst)
+
{- SYB Queries -}
-listTypes :: Module -> [String]
-listTypes m = (map prettyPrint (collectTypes m))
- where
- collectTypes :: Module -> [QName]
- collectTypes = nub . everything (++) ([] `mkQ` getData) where
- getData :: Type -> [QName]
- getData (TyCon n) = [n]
- getData _ = []
- -- getType :: Decl -> [QName]
- -- getType (DataDecl _ _ _ _ decl _ _) = let f (Ident n) = [n]
- -- f _ = []
- -- in f decl
- --
- -- getType _ = []
-
-listConstructors :: Module -> [String]
-listConstructors = nub . everything (++) ([] `mkQ` listConstructor
- `extQ` listConstructorPat
- `extQ` listConstructorUse)
- where listConstructor :: ConDecl -> [String]
- listConstructor (ConDecl (i) _) = [prettyPrint i]
- listConstructor (InfixConDecl _ i _) = [prettyPrint i]
- listConstructor (RecDecl i _) = [prettyPrint i]
- listConstructorPat :: Pat -> [String]
- listConstructorPat (PApp i _) = [prettyPrint i]
- listConstructorPat _ = []
- listConstructorUse :: Exp -> [String]
- listConstructorUse (Con i) = [prettyPrint i]
- listConstructorUse _ = []
-
-listFunctions :: Module -> [String]
-listFunctions = nub . everything (++) ([] `mkQ` functionBinding
- `extQ` functionUse
- `extQ` functionTypeSig)
- where functionBinding :: Match -> [String]
- functionBinding (Match _ (i) _ _ _ _) = [prettyPrint i]
- functionUse :: Exp -> [String]
- functionUse (App (Var qname) _) = [prettyPrint qname]
- functionUse _ = []
- functionTypeSig :: Decl -> [String]
- functionTypeSig (TypeSig _ names t) = case t of
- TyParen (TyFun _ _) -> map nameToString names
- TyFun _ _ -> map nameToString names
- _ -> []
- functionTypeSig _ = []
- nameToString :: Name -> String
- nameToString (Ident s) = s
- nameToString (Symbol s) = s
+searchTypes :: ItemQuery Type
+searchTypes (TyCon n) = [Type (prettyPrint n)]
+searchTypes _ = []
+
+searchConDecl :: ItemQuery ConDecl
+searchConDecl (ConDecl (i) _) = [Constructor $ prettyPrint i]
+searchConDecl (InfixConDecl _ i _) = [Constructor $ prettyPrint i]
+searchConDecl (RecDecl i _) = [Constructor $ prettyPrint i]
+
+searchPat :: ItemQuery Pat
+searchPat (PApp i _) = [Constructor $ prettyPrint i]
+searchPat _ = []
+
+searchExp :: ItemQuery Exp
+searchExp (Con i) = [Constructor $ prettyPrint i]
+searchExp (App (Var qname) _) = [Function $ prettyPrint qname]
+searchExp (InfixApp _ qop _) = [Operator $ prettyPrint qop]
+searchExp _ = []
+
+searchMat :: ItemQuery Match
+searchMat (Match _ (i) _ _ _ _) = [Function $ prettyPrint i]
+
+searchDecl :: ItemQuery Decl
+searchDecl (TypeSig _ names t) = case t of
+ TyParen (TyFun _ _) -> map nameToString names
+ TyFun _ _ -> map nameToString names
+ _ -> []
+ where nameToString :: Name -> Item
+ nameToString (Ident s) = Function s
+ nameToString (Symbol s) = Function s
+searchDecl (ClassDecl _ _ name _ _ _) = [Class $ prettyPrint name]
+searchDecl _ = []
+
-listOperators :: Module -> [String]
-listOperators = nub . everything (++) ([] `mkQ` operatorUse)
- where operatorUse :: Exp -> [String]
- operatorUse (InfixApp _ qop _) = [prettyPrint qop]
- operatorUse _ = []
-
-listClasses :: Module -> [String]
-listClasses = nub . everything (++) ([] `mkQ` listClassDeriving
- `extQ` listClassDecl
- `extQ` listClassContext)
- where listClassDeriving :: Deriving -> [String]
- listClassDeriving (name , _) = [prettyPrint name]
- listClassDecl :: Decl -> [String]
- listClassDecl (ClassDecl _ _ name _ _ _) = [prettyPrint name]
- listClassDecl _ = []
- listClassContext :: Asst -> [String]
- listClassContext (ClassA name _) = [prettyPrint name]
- listClassContext _ = []
-
-
-getSimpleInfo m = simpleinfo{ types = listTypes m
- , constructors = listConstructors m
- , functions = listFunctions m
- , operators = listOperators m
- , classes = listClasses m
+
+
+searchDeriving :: ItemQuery Deriving
+searchDeriving (name , _) = [Class $ prettyPrint name]
+
+searchAsst :: ItemQuery Asst
+searchAsst (ClassA name _) = [Class $ prettyPrint name]
+searchAsst _ = []
+
+
+getSimpleInfo m = simpleinfo{ types = f isT
+ , constructors = f isCo
+ , functions = f isF
+ , operators = f isO
+ , classes = f isCl
}
+ where f p = map show (filter p collection)
+ isT (Type _) = True
+ isT _ = False
+ isCo (Constructor _) = True
+ isCo _ = False
+ isF (Function _) = True
+ isF _ = False
+ isO (Operator _) = True
+ isO _ = False
+ isCl (Class _) = True
+ isCl _ = False
+ collection = collect m
mapping :: [(String, SimpleInfo -> [(String,String)])]
-mapping = [ ("syntax", syntax)
- , ("keyword", keywords)
- , ("prelude", prelude)
- -- , ("applicative", applicative )
- , ("type", mtypes)
+mapping = [
+ ("type", mtypes)
, ("constructor", mconstructors)
, ("function", mfunctions)
, ("infixoperator", moperators)
@@ -129,54 +133,7 @@ mconstructors SimpleInfo{constructors} = map (dp) constructors
mfunctions SimpleInfo{functions } = map (dp) functions
mclasses SimpleInfo{classes} = map (dp) classes
-syntax _ = map dp [ "=", "{", "}", "(", ")", "<-", "->", "=>", ","
- ]
-
-keywords _ = map dp [ "data", "deriving", "type", "instance", "family", "where"
- , "newtype", "if", "then", "else", "case", "of", "module"
- , "as", "hiding", "import", "let", "in", "do", "class"]
-
-prelude SimpleInfo{functions } = map dp $
- filter ((flip elem) functions)
- ["abs" , "acos" , "acosh" , "all" , "and" , "any" ,
- "appendFile" , "applyM" , "asTypeOf" , "asin" , "asinh" ,
- "atan" , "atan2" , "atanh" , "break" , "catch" , "ceiling",
- "compare" , "concat" , "concatMap" , "const" , "cos" ,
- "cosh" , "curry" , "cycle" , "decodeFloat" , "div" ,
- "divMod" , "drop" , "dropWhile" , "elem" , "encodeFloat" ,
- "enumFrom" , "enumFromThen" , "enumFromThenTo" ,
- "enumFromTo" , "error" , "even" , "exp" , "exponent" ,
- "fail" , "filter" , "flip" , "floatDigits" , "floatRadix" ,
- "floatRange" , "floor" , "fmap" , "foldl" , "foldl1" ,
- "foldr" , "foldr1" , "fromEnum" , "fromInteger" ,
- "fromIntegral" , "fromRational" , "fst" , "gcd" ,
- "getChar" , "getContents" , "getLine" , "head" , "id" ,
- "init" , "interact" , "ioError" , "isDenormalized" ,
- "isIEEE" , "isInfinite" , "isNaN" , "isNegativeZero" ,
- "iterate" , "last" , "lcm" , "length" , "lex" , "lines" ,
- "log" , "logBase" , "lookup" , "map" , "mapM" , "mapM_" ,
- "max" , "maxBound" , "maximum" , "maybe" , "min" ,
- "minBound" , "minimum" , "mod" , "negate" , "not" ,
- "notElem" , "null" , "odd" , "or" , "otherwise" , "pi" ,
- "pred" , "print" , "product" , "properFraction" ,
- "putChar" , "putStr" , "putStrLn" , "quot" , "quotRem" ,
- "read" , "readFile" , "readIO" , "readList" , "readLn" ,
- "readParen" , "reads" , "readsPrec" , "realToFrac" ,
- "recip" , "rem" , "repeat" , "replicate" , "return" ,
- "reverse" , "round" , "scaleFloat" , "scanl" , "scanl1" ,
- "scanr" , "scanr1" , "seq" , "sequence" , "sequence_" ,
- "show" , "showChar" , "showList" , "showParen" ,
- "showString" , "shows" , "showsPrec" , "significand" ,
- "signum" , "sin" , "sinh" , "snd" , "span" , "splitAt" ,
- "sqrt" , "subtract" , "succ" , "sum" , "tail" , "take" ,
- "takeWhile" , "tan" , "tanh" , "toEnum" , "toInteger" ,
- "toRational" , "truncate" , "uncurry" ,
- "unlines" , "until" , "unwords" , "unzip" , "unzip3" ,
- "userError" , "words" , "writeFile" , "zip" , "zip3" ,
- "zipWith" , "zipWith3", "$"]
-
-
-applicative _ = []
+
fooz = [4, 13, 42]
douz = [4.0, 13.0, 42.0]
View
3  src/Literate/SimpleInfo.hs
@@ -19,4 +19,5 @@ simpleinfo = SimpleInfo{ fileName = ""
, functions = []
, operators = []
, classes = []
- }
+ }
+
Please sign in to comment.
Something went wrong with that request. Please try again.