    -- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations
    module Language.Haskell.HsColour.ACSS (
        hscolour
      , hsannot
      , AnnMap (..)
      , Loc (..)
      , breakS
      , srcModuleName
      ) where

    import Language.Haskell.HsColour.Anchors
    import Language.Haskell.HsColour.Classify as Classify
    import Language.Haskell.HsColour.HTML (renderAnchors, renderComment,
                                           renderNewLinesAnchors, escape)
    import qualified Language.Haskell.HsColour.CSS as CSS

    import Data.Maybe  (fromMaybe)
    import qualified Data.Map as M
    import Data.List   (isSuffixOf, findIndex, elemIndices, intercalate)
    import Data.Char   (isLower, isSpace, isAlphaNum)
    import Text.Printf
    import Debug.Trace

    newtype AnnMap = Ann (M.Map Loc (String, String))
    newtype Loc    = L (Int, Int) deriving (Loc -> Loc -> Bool
    (Loc -> Loc -> Bool) -> (Loc -> Loc -> Bool) -> Eq Loc
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Loc -> Loc -> Bool
    == :: Loc -> Loc -> Bool
    $c/= :: Loc -> Loc -> Bool
    /= :: Loc -> Loc -> Bool
    Eq, Eq Loc
    Eq Loc =>
    (Loc -> Loc -> Ordering)
    -> (Loc -> Loc -> Bool)
    -> (Loc -> Loc -> Bool)
    -> (Loc -> Loc -> Bool)
    -> (Loc -> Loc -> Bool)
    -> (Loc -> Loc -> Loc)
    -> (Loc -> Loc -> Loc)
    -> Ord Loc
    Loc -> Loc -> Bool
    Loc -> Loc -> Ordering
    Loc -> Loc -> Loc
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: Loc -> Loc -> Ordering
    compare :: Loc -> Loc -> Ordering
    $c< :: Loc -> Loc -> Bool
    < :: Loc -> Loc -> Bool
    $c<= :: Loc -> Loc -> Bool
    <= :: Loc -> Loc -> Bool
    $c> :: Loc -> Loc -> Bool
    > :: Loc -> Loc -> Bool
    $c>= :: Loc -> Loc -> Bool
    >= :: Loc -> Loc -> Bool
    $cmax :: Loc -> Loc -> Loc
    max :: Loc -> Loc -> Loc
    $cmin :: Loc -> Loc -> Loc
    min :: Loc -> Loc -> Loc
    Ord, Int -> Loc -> String -> String
    [Loc] -> String -> String
    Loc -> String
    (Int -> Loc -> String -> String)
    -> (Loc -> String) -> ([Loc] -> String -> String) -> Show Loc
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> Loc -> String -> String
    showsPrec :: Int -> Loc -> String -> String
    $cshow :: Loc -> String
    show :: Loc -> String
    $cshowList :: [Loc] -> String -> String
    showList :: [Loc] -> String -> String
    Show)

    -- | Formats Haskell source code using HTML and mouse-over annotations
    hscolour :: Bool     -- ^ Whether to include anchors.
             -> Int      -- ^ Starting line number (for line anchors).
             -> String   -- ^ Haskell source code, Annotations as comments at end
             -> String   -- ^ Coloured Haskell source code.

    hscolour :: Bool -> Int -> String -> String
    hscolour Bool
    anchor Int
    n = Bool -> Int -> (String, AnnMap) -> String
    hsannot Bool
    anchor Int
    n ((String, AnnMap) -> String)
    -> (String -> (String, AnnMap)) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> (String, AnnMap)
    splitSrcAndAnns

    -- | Formats Haskell source code using HTML and mouse-over annotations
    hsannot  :: Bool             -- ^ Whether to include anchors.
             -> Int              -- ^ Starting line number (for line anchors).
             -> (String, AnnMap) -- ^ Haskell Source, Annotations
             -> String           -- ^ Coloured Haskell source code.

    hsannot :: Bool -> Int -> (String, AnnMap) -> String
    hsannot Bool
    anchor Int
    n =
        String -> String
    CSS.pre
        (String -> String)
    -> ((String, AnnMap) -> String) -> (String, AnnMap) -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (if Bool
    anchor then -- renderNewLinesAnchors n .
                          (Either String (TokenType, String, Maybe String) -> String)
    -> [Either String (TokenType, String, Maybe String)] -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (((TokenType, String, Maybe String) -> String)
    -> Either String (TokenType, String, Maybe String) -> String
    forall a. (a -> String) -> Either String a -> String
    renderAnchors (TokenType, String, Maybe String) -> String
    renderAnnotToken)
                          ([Either String (TokenType, String, Maybe String)] -> String)
    -> ([(TokenType, String, Maybe String)]
        -> [Either String (TokenType, String, Maybe String)])
    -> [(TokenType, String, Maybe String)]
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(TokenType, String, Maybe String)]
    -> [Either String (TokenType, String, Maybe String)]
    forall a.
    [(TokenType, String, a)] -> [Either String (TokenType, String, a)]
    insertAnnotAnchors
                     else ((TokenType, String, Maybe String) -> String)
    -> [(TokenType, String, Maybe String)] -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (TokenType, String, Maybe String) -> String
    renderAnnotToken)
        ([(TokenType, String, Maybe String)] -> String)
    -> ((String, AnnMap) -> [(TokenType, String, Maybe String)])
    -> (String, AnnMap)
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String, AnnMap) -> [(TokenType, String, Maybe String)]
    annotTokenise

    annotTokenise  :: (String, AnnMap) -> [(TokenType, String, Maybe String)]
    annotTokenise :: (String, AnnMap) -> [(TokenType, String, Maybe String)]
    annotTokenise (String
    src, Ann Map Loc (String, String)
    annm)
      = ((TokenType, String)
     -> Maybe (String, String) -> (TokenType, String, Maybe String))
    -> [(TokenType, String)]
    -> [Maybe (String, String)]
    -> [(TokenType, String, Maybe String)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\(TokenType
    x,String
    y) Maybe (String, String)
    z -> (TokenType
    x,String
    y, (String, String) -> String
    forall a b. (a, b) -> b
    snd ((String, String) -> String)
    -> Maybe (String, String) -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` Maybe (String, String)
    z)) [(TokenType, String)]
    toks [Maybe (String, String)]
    annots
      where toks :: [(TokenType, String)]
    toks       = String -> [(TokenType, String)]
    tokenise String
    src
            spans :: [Loc]
    spans      = [String] -> [Loc]
    tokenSpans ([String] -> [Loc]) -> [String] -> [Loc]
    forall a b. (a -> b) -> a -> b
    $ ((TokenType, String) -> String)
    -> [(TokenType, String)] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (TokenType, String) -> String
    forall a b. (a, b) -> b
    snd [(TokenType, String)]
    toks
            annots :: [Maybe (String, String)]
    annots     = (Loc -> Maybe (String, String))
    -> [Loc] -> [Maybe (String, String)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Loc -> Map Loc (String, String) -> Maybe (String, String)
    forall k a. Ord k => k -> Map k a -> Maybe a
    `M.lookup` Map Loc (String, String)
    annm) [Loc]
    spans

    tokenSpans :: [String] -> [Loc]
    tokenSpans :: [String] -> [Loc]
    tokenSpans = (Loc -> String -> Loc) -> Loc -> [String] -> [Loc]
    forall b a. (b -> a -> b) -> b -> [a] -> [b]
    scanl Loc -> String -> Loc
    plusLoc ((Int, Int) -> Loc
    L (Int
    1, Int
    1))

    plusLoc :: Loc -> String -> Loc
    plusLoc :: Loc -> String -> Loc
    plusLoc (L (Int
    l, Int
    c)) String
    s
      = case Char
    '\n' Char -> String -> [Int]
    forall a. Eq a => a -> [a] -> [Int]
    `elemIndices` String
    s of
          [] -> (Int, Int) -> Loc
    L (Int
    l, (Int
    c Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    n))
          [Int]
    is -> (Int, Int) -> Loc
    L ((Int
    l Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [Int] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Int]
    is), (Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum [Int]
    is))
        where n :: Int
    n = String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    s

    renderAnnotToken :: (TokenType, String, Maybe String) -> String
    renderAnnotToken :: (TokenType, String, Maybe String) -> String
    renderAnnotToken (TokenType
    x,String
    y, Maybe String
    Nothing)
      = (TokenType, String) -> String
    CSS.renderToken (TokenType
    x, String
    y)
    renderAnnotToken (TokenType
    x,String
    y, Just String
    ann)
      = String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    template (String -> String
    escape String
    ann) ((TokenType, String) -> String
    CSS.renderToken (TokenType
    x, String
    y))
        where template :: String
    template = String
    "<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>"

    {- Example Annotation:
    <a class=annot href="#"><span class=annottext>x#agV:Int -&gt; {VV_int:Int | (0 &lt;= VV_int),(x#agV &lt;= VV_int)}</span>
    <span class='hs-definition'>NOWTRYTHIS</span></a>
    -}

    insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)]
    insertAnnotAnchors :: forall a.
    [(TokenType, String, a)] -> [Either String (TokenType, String, a)]
    insertAnnotAnchors [(TokenType, String, a)]
    toks
      = [((TokenType, String), (TokenType, String, a))]
    -> [Either String (TokenType, String)]
    -> [Either String (TokenType, String, a)]
    forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
    stitch ([(TokenType, String)]
    -> [(TokenType, String, a)]
    -> [((TokenType, String), (TokenType, String, a))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [(TokenType, String)]
    toks' [(TokenType, String, a)]
    toks) ([Either String (TokenType, String)]
     -> [Either String (TokenType, String, a)])
    -> [Either String (TokenType, String)]
    -> [Either String (TokenType, String, a)]
    forall a b. (a -> b) -> a -> b
    $ [(TokenType, String)] -> [Either String (TokenType, String)]
    insertAnchors [(TokenType, String)]
    toks'
      where toks' :: [(TokenType, String)]
    toks' = [(TokenType
    x,String
    y) | (TokenType
    x,String
    y,a
    _) <- [(TokenType, String, a)]
    toks]

    stitch ::  Eq b => [(b, c)] -> [Either a b] -> [Either a c]
    stitch :: forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
    stitch [(b, c)]
    xys ((Left a
    a) : [Either a b]
    rest)
      = (a -> Either a c
    forall a b. a -> Either a b
    Left a
    a) Either a c -> [Either a c] -> [Either a c]
    forall a. a -> [a] -> [a]
    : [(b, c)] -> [Either a b] -> [Either a c]
    forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
    stitch [(b, c)]
    xys [Either a b]
    rest
    stitch ((b
    x,c
    y):[(b, c)]
    xys) ((Right b
    x'):[Either a b]
    rest)
      | b
    x b -> b -> Bool
    forall a. Eq a => a -> a -> Bool
    == b
    x'
      = (c -> Either a c
    forall a b. b -> Either a b
    Right c
    y) Either a c -> [Either a c] -> [Either a c]
    forall a. a -> [a] -> [a]
    : [(b, c)] -> [Either a b] -> [Either a c]
    forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
    stitch [(b, c)]
    xys [Either a b]
    rest
      | Bool
    otherwise
      = String -> [Either a c]
    forall a. HasCallStack => String -> a
    error String
    "stitch"
    stitch [(b, c)]
    _ []
      = []

    splitSrcAndAnns ::  String -> (String, AnnMap)
    splitSrcAndAnns :: String -> (String, AnnMap)
    splitSrcAndAnns String
    s =
      let ls :: [String]
    ls = String -> [String]
    lines String
    s in
      case (String -> Bool) -> [String] -> Maybe Int
    forall a. (a -> Bool) -> [a] -> Maybe Int
    findIndex (String
    breakS String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    ==) [String]
    ls of
        Maybe Int
    Nothing -> (String
    s, Map Loc (String, String) -> AnnMap
    Ann Map Loc (String, String)
    forall k a. Map k a
    M.empty)
        Just Int
    i  -> (String
    src, {- trace ("annm =" ++ show ann) -} AnnMap
    ann)
                   where ([String]
    codes, String
    _:String
    mname:[String]
    annots) = Int -> [String] -> ([String], [String])
    forall a. Int -> [a] -> ([a], [a])
    splitAt Int
    i [String]
    ls
                         ann :: AnnMap
    ann   = String -> String -> AnnMap
    annotParse String
    mname (String -> AnnMap) -> String -> AnnMap
    forall a b. (a -> b) -> a -> b
    $ (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines [String]
    annots
                         src :: String
    src   = [String] -> String
    unlines [String]
    codes
                         -- mname = srcModuleName src

    srcModuleName :: String -> String
    srcModuleName :: String -> String
    srcModuleName = String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe String
    "Main" (Maybe String -> String)
    -> (String -> Maybe String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(TokenType, String)] -> Maybe String
    tokenModule ([(TokenType, String)] -> Maybe String)
    -> (String -> [(TokenType, String)]) -> String -> Maybe String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [(TokenType, String)]
    tokenise

    tokenModule :: [(TokenType, String)] -> Maybe String
    tokenModule [(TokenType, String)]
    toks
      = do i <- ((TokenType, String) -> Bool) -> [(TokenType, String)] -> Maybe Int
    forall a. (a -> Bool) -> [a] -> Maybe Int
    findIndex ((TokenType
    Keyword, String
    "module") (TokenType, String) -> (TokenType, String) -> Bool
    forall a. Eq a => a -> a -> Bool
    ==) [(TokenType, String)]
    toks
           let (_, toks')  = splitAt (i+2) toks
           j <- findIndex ((Space ==) . fst) toks'
           let (toks'', _) = splitAt j toks'
           return $ concatMap snd toks''

    breakS :: String
    breakS = String
    "MOUSEOVER ANNOTATIONS"

    annotParse :: String -> String -> AnnMap
    annotParse :: String -> String -> AnnMap
    annotParse String
    mname = Map Loc (String, String) -> AnnMap
    Ann (Map Loc (String, String) -> AnnMap)
    -> (String -> Map Loc (String, String)) -> String -> AnnMap
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(Loc, (String, String))] -> Map Loc (String, String)
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList ([(Loc, (String, String))] -> Map Loc (String, String))
    -> (String -> [(Loc, (String, String))])
    -> String
    -> Map Loc (String, String)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Int -> [String] -> [(Loc, (String, String))]
    parseLines String
    mname Int
    0 ([String] -> [(Loc, (String, String))])
    -> (String -> [String]) -> String -> [(Loc, (String, String))]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    lines

    parseLines :: String -> Int -> [String] -> [(Loc, (String, String))]
    parseLines String
    mname Int
    i []
      = []
    parseLines String
    mname Int
    i (String
    "":[String]
    ls)
      = String -> Int -> [String] -> [(Loc, (String, String))]
    parseLines String
    mname (Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) [String]
    ls
    parseLines String
    mname Int
    i (String
    x:String
    f:String
    l:String
    c:String
    n:[String]
    rest)
      | String
    f String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String
    mname -- `isSuffixOf` mname
      = {- trace ("wrong annot f = " ++ f ++ " mname = " ++ mname) $ -} String -> Int -> [String] -> [(Loc, (String, String))]
    parseLines String
    mname (Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    5 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    num) [String]
    rest'
      | Bool
    otherwise
      = ((Int, Int) -> Loc
    L (Int
    line, Int
    col), (String
    x, String
    anns)) (Loc, (String, String))
    -> [(Loc, (String, String))] -> [(Loc, (String, String))]
    forall a. a -> [a] -> [a]
    : String -> Int -> [String] -> [(Loc, (String, String))]
    parseLines String
    mname (Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    5 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    num) [String]
    rest'
        where line :: Int
    line  = (String -> Int
    forall a. Read a => String -> a
    read String
    l) :: Int
              col :: Int
    col   = (String -> Int
    forall a. Read a => String -> a
    read String
    c) :: Int
              num :: Int
    num   = (String -> Int
    forall a. Read a => String -> a
    read String
    n) :: Int
              anns :: String
    anns  = String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    "\n" ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ Int -> [String] -> [String]
    forall a. Int -> [a] -> [a]
    take Int
    num [String]
    rest
              rest' :: [String]
    rest' = Int -> [String] -> [String]
    forall a. Int -> [a] -> [a]
    drop Int
    num [String]
    rest
    parseLines String
    _ Int
    i [String]
    _
      = String -> [(Loc, (String, String))]
    forall a. HasCallStack => String -> a
    error (String -> [(Loc, (String, String))])
    -> String -> [(Loc, (String, String))]
    forall a b. (a -> b) -> a -> b
    $ String
    "Error Parsing Annot Input on Line: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    i

    takeFileName :: String -> String
    takeFileName String
    s = (Char -> Char) -> String -> String
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    slashWhite String
    s
      where slashWhite :: Char -> Char
    slashWhite Char
    '/' = Char
    ' '

    instance Show AnnMap where
      show :: AnnMap -> String
    show (Ann Map Loc (String, String)
    m) = String
    "\n\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (((Loc, (String, String)) -> String)
    -> [(Loc, (String, String))] -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (Loc, (String, String)) -> String
    ppAnnot ([(Loc, (String, String))] -> String)
    -> [(Loc, (String, String))] -> String
    forall a b. (a -> b) -> a -> b
    $ Map Loc (String, String) -> [(Loc, (String, String))]
    forall k a. Map k a -> [(k, a)]
    M.toList Map Loc (String, String)
    m)
        where ppAnnot :: (Loc, (String, String)) -> String
    ppAnnot (L (Int
    l, Int
    c), (String
    x,String
    s)) =  String
    x String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n"
                                        String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    l String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n"
                                        String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    c String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n"
                                        String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show ([String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ([String] -> Int) -> [String] -> Int
    forall a b. (a -> b) -> a -> b
    $ String -> [String]
    lines String
    s) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n"
                                        String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n\n\n"