{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

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

import Prelude hiding (error)
import qualified Liquid.GHC.API as SrcLoc

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

import Data.Either (partitionEithers)
import Data.Maybe  (fromMaybe)
import qualified Data.HashMap.Strict as M
import Data.List   (find, isPrefixOf, findIndex, elemIndices, intercalate, elemIndex)
import Data.Char   (isSpace)
import Text.Printf
import Language.Haskell.Liquid.GHC.Misc
import Language.Haskell.Liquid.Types.Errors (panic, impossible)

data AnnMap  = Ann
  { AnnMap -> HashMap Loc ([Char], [Char])
types   :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)
  , AnnMap -> [(Loc, Loc, [Char])]
errors  :: [(Loc, Loc, String)]           -- ^ List of error intervals
  , AnnMap -> Status
status  :: !Status
  , AnnMap -> [(RealSrcSpan, ([Char], [Char]))]
sptypes :: ![(SrcLoc.RealSrcSpan, (String, String)) ]-- ^ Type information with spans
  }

data Status = Safe | Unsafe | Error | Crash
              deriving (Status -> Status -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, Eq Status
Status -> Status -> Bool
Status -> Status -> Ordering
Status -> Status -> Status
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
min :: Status -> Status -> Status
$cmin :: Status -> Status -> Status
max :: Status -> Status -> Status
$cmax :: Status -> Status -> Status
>= :: Status -> Status -> Bool
$c>= :: Status -> Status -> Bool
> :: Status -> Status -> Bool
$c> :: Status -> Status -> Bool
<= :: Status -> Status -> Bool
$c<= :: Status -> Status -> Bool
< :: Status -> Status -> Bool
$c< :: Status -> Status -> Bool
compare :: Status -> Status -> Ordering
$ccompare :: Status -> Status -> Ordering
Ord, Int -> Status -> ShowS
[Status] -> ShowS
Status -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> [Char]
$cshow :: Status -> [Char]
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show)

data Annotation = A {
    Annotation -> Maybe [Char]
typ :: Maybe String         -- ^ type  string
  , Annotation -> Maybe [Char]
err :: Maybe String         -- ^ error string
  , Annotation -> Maybe (Int, Int)
lin :: Maybe (Int, Int)     -- ^ line number, total width of lines i.e. max (length (show lineNum))
  } deriving (Int -> Annotation -> ShowS
[Annotation] -> ShowS
Annotation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Annotation] -> ShowS
$cshowList :: [Annotation] -> ShowS
show :: Annotation -> [Char]
$cshow :: Annotation -> [Char]
showsPrec :: Int -> Annotation -> ShowS
$cshowsPrec :: Int -> Annotation -> ShowS
Show)


-- | Formats Haskell source code using HTML and mouse-over annotations
hscolour :: Bool     -- ^ Whether to include anchors.
         -> Bool     -- ^ Whether input document is literate haskell or not
         -> String   -- ^ Haskell source code, Annotations as comments at end
         -> String   -- ^ Coloured Haskell source code.

hscolour :: Bool -> Bool -> ShowS
hscolour Bool
anchor Bool
lhs = Bool -> CommentTransform -> Bool -> ([Char], AnnMap) -> [Char]
hsannot Bool
anchor forall a. Maybe a
Nothing Bool
lhs forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ([Char], AnnMap)
splitSrcAndAnns

type CommentTransform = Maybe (String -> [(TokenType, String)])

-- | Formats Haskell source code using HTML and mouse-over annotations
hsannot  :: Bool             -- ^ Whether to include anchors.
         -> CommentTransform -- ^ Function to refine comment tokens
         -> Bool             -- ^ Whether input document is literate haskell or not
         -> (String, AnnMap) -- ^ Haskell Source, Annotations
         -> String           -- ^ Coloured Haskell source code.

hsannot :: Bool -> CommentTransform -> Bool -> ([Char], AnnMap) -> [Char]
hsannot Bool
anchor CommentTransform
tx Bool
False ([Char], AnnMap)
z     = Maybe Loc -> Bool -> CommentTransform -> ([Char], AnnMap) -> [Char]
hsannot' forall a. Maybe a
Nothing Bool
anchor CommentTransform
tx ([Char], AnnMap)
z
hsannot Bool
anchor CommentTransform
tx Bool
True ([Char]
s, AnnMap
m) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Lit, Loc) -> [Char]
chunk forall a b. (a -> b) -> a -> b
$ [Lit] -> [(Lit, Loc)]
litSpans forall a b. (a -> b) -> a -> b
$ [Lit] -> [Lit]
joinL forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Lit]
classify forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
inlines [Char]
s
  where chunk :: (Lit, Loc) -> [Char]
chunk (Code [Char]
c, Loc
l)     = Maybe Loc -> Bool -> CommentTransform -> ([Char], AnnMap) -> [Char]
hsannot' (forall a. a -> Maybe a
Just Loc
l) Bool
anchor CommentTransform
tx ([Char]
c, AnnMap
m)
        chunk (Lit [Char]
c , Loc
_)     = [Char]
c

litSpans :: [Lit] -> [(Lit, Loc)]
litSpans :: [Lit] -> [(Lit, Loc)]
litSpans [Lit]
lits = forall a b. [a] -> [b] -> [(a, b)]
zip [Lit]
lits forall a b. (a -> b) -> a -> b
$ [Lit] -> [Loc]
spans [Lit]
lits
  where spans :: [Lit] -> [Loc]
spans = Maybe Loc -> [[Char]] -> [Loc]
tokenSpans forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Lit -> [Char]
unL

hsannot' :: Maybe Loc
         -> Bool -> CommentTransform -> (String, AnnMap) -> String
hsannot' :: Maybe Loc -> Bool -> CommentTransform -> ([Char], AnnMap) -> [Char]
hsannot' Maybe Loc
baseLoc Bool
anchor CommentTransform
tx =
    ShowS
CSS.pre
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
anchor then forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. (a -> [Char]) -> Either [Char] a -> [Char]
renderAnchors (TokenType, [Char], Annotation) -> [Char]
renderAnnotToken)
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
[(TokenType, [Char], a)] -> [Either [Char] (TokenType, [Char], a)]
insertAnnotAnchors
                 else forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TokenType, [Char], Annotation) -> [Char]
renderAnnotToken)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Loc
-> CommentTransform
-> ([Char], AnnMap)
-> [(TokenType, [Char], Annotation)]
annotTokenise Maybe Loc
baseLoc CommentTransform
tx

tokeniseWithLoc :: CommentTransform -> String -> [(TokenType, String, Loc)]
tokeniseWithLoc :: CommentTransform -> [Char] -> [(TokenType, [Char], Loc)]
tokeniseWithLoc CommentTransform
tx [Char]
str = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(TokenType
x,[Char]
y) Loc
z -> (TokenType
x, [Char]
y, Loc
z)) [(TokenType, [Char])]
toks [Loc]
spans
  where
    toks :: [(TokenType, [Char])]
toks       = CommentTransform -> [Char] -> [(TokenType, [Char])]
tokeniseWithCommentTransform CommentTransform
tx [Char]
str
    spans :: [Loc]
spans      = Maybe Loc -> [[Char]] -> [Loc]
tokenSpans forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(TokenType, [Char])]
toks

-- | annotTokenise is absurdly slow: O(#tokens x #errors)

annotTokenise :: Maybe Loc -> CommentTransform -> (String, AnnMap) -> [(TokenType, String, Annotation)]
annotTokenise :: Maybe Loc
-> CommentTransform
-> ([Char], AnnMap)
-> [(TokenType, [Char], Annotation)]
annotTokenise Maybe Loc
baseLoc CommentTransform
tx ([Char]
src, AnnMap
annm) = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(TokenType
x,[Char]
y) Annotation
z -> (TokenType
x,[Char]
y,Annotation
z)) [(TokenType, [Char])]
toks [Annotation]
annots
  where
    toks :: [(TokenType, [Char])]
toks       = CommentTransform -> [Char] -> [(TokenType, [Char])]
tokeniseWithCommentTransform CommentTransform
tx [Char]
src
    spans :: [Loc]
spans      = Maybe Loc -> [[Char]] -> [Loc]
tokenSpans Maybe Loc
baseLoc forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(TokenType, [Char])]
toks
    annots :: [Annotation]
annots     = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> AnnMap -> Loc -> Annotation
spanAnnot Int
linWidth AnnMap
annm) [Loc]
spans
    linWidth :: Int
linWidth   = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
src

spanAnnot :: Int -> AnnMap -> Loc -> Annotation
spanAnnot :: Int -> AnnMap -> Loc -> Annotation
spanAnnot Int
w (Ann HashMap Loc ([Char], [Char])
ts [(Loc, Loc, [Char])]
es Status
_ [(RealSrcSpan, ([Char], [Char]))]
_) Loc
loc = Maybe [Char] -> Maybe [Char] -> Maybe (Int, Int) -> Annotation
A Maybe [Char]
t Maybe [Char]
e Maybe (Int, Int)
b
  where
    t :: Maybe [Char]
t = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Loc
loc HashMap Loc ([Char], [Char])
ts)
    e :: Maybe [Char]
e = [Char]
"ERROR" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Loc
loc Loc -> (Loc, Loc) -> Bool
`inRange`) [(Loc
x,Loc
y) | (Loc
x,Loc
y,[Char]
_) <- [(Loc, Loc, [Char])]
es]
    b :: Maybe (Int, Int)
b = forall t. t -> Loc -> Maybe (Int, t)
spanLine Int
w Loc
loc

spanLine :: t -> Loc -> Maybe (Int, t)
spanLine :: forall t. t -> Loc -> Maybe (Int, t)
spanLine t
w (L (Int
l, Int
c))
  | Int
c forall a. Eq a => a -> a -> Bool
== Int
1    = forall a. a -> Maybe a
Just (Int
l, t
w)
  | Bool
otherwise = forall a. Maybe a
Nothing

inRange :: Loc -> (Loc, Loc) -> Bool
inRange :: Loc -> (Loc, Loc) -> Bool
inRange (L (Int
l0, Int
c0)) (L (Int
l, Int
c), L (Int
l', Int
c'))
  = Int
l forall a. Ord a => a -> a -> Bool
<= Int
l0 Bool -> Bool -> Bool
&& Int
c forall a. Ord a => a -> a -> Bool
<= Int
c0 Bool -> Bool -> Bool
&& Int
l0 forall a. Ord a => a -> a -> Bool
<= Int
l' Bool -> Bool -> Bool
&& Int
c0 forall a. Ord a => a -> a -> Bool
< Int
c'

tokeniseWithCommentTransform :: Maybe (String -> [(TokenType, String)]) -> String -> [(TokenType, String)]
tokeniseWithCommentTransform :: CommentTransform -> [Char] -> [(TokenType, [Char])]
tokeniseWithCommentTransform CommentTransform
Nothing  = [Char] -> [(TokenType, [Char])]
tokenise
tokeniseWithCommentTransform (Just [Char] -> [(TokenType, [Char])]
g) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {t}.
(t -> [(TokenType, t)]) -> (TokenType, t) -> [(TokenType, t)]
expand [Char] -> [(TokenType, [Char])]
g) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [(TokenType, [Char])]
tokenise
  where expand :: (t -> [(TokenType, t)]) -> (TokenType, t) -> [(TokenType, t)]
expand t -> [(TokenType, t)]
f (TokenType
Comment, t
s) = t -> [(TokenType, t)]
f t
s
        expand t -> [(TokenType, t)]
_ (TokenType, t)
z            = [(TokenType, t)
z]

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

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

renderAnnotToken :: (TokenType, String, Annotation) -> String
renderAnnotToken :: (TokenType, [Char], Annotation) -> [Char]
renderAnnotToken (TokenType
x, [Char]
y, Annotation
a)  = forall t t1.
(Show t, PrintfArg t1, PrintfType t1) =>
Maybe (t, Int) -> t1 -> t1
renderLinAnnot (Annotation -> Maybe (Int, Int)
lin Annotation
a)
                            forall a b. (a -> b) -> a -> b
$ forall t1 t. (PrintfArg t1, PrintfType t1) => Maybe t -> t1 -> t1
renderErrAnnot (Annotation -> Maybe [Char]
err Annotation
a)
                            forall a b. (a -> b) -> a -> b
$ forall t. (PrintfArg t, PrintfType t) => Maybe [Char] -> t -> t
renderTypAnnot (Annotation -> Maybe [Char]
typ Annotation
a)
                            forall a b. (a -> b) -> a -> b
$ (TokenType, [Char]) -> [Char]
CSS.renderToken (TokenType
x, [Char]
y)



renderTypAnnot :: (PrintfArg t, PrintfType t) => Maybe String -> t -> t
renderTypAnnot :: forall t. (PrintfArg t, PrintfType t) => Maybe [Char] -> t -> t
renderTypAnnot (Just [Char]
ann) t
s = forall r. PrintfType r => [Char] -> r
printf [Char]
"<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>" (ShowS
escape [Char]
ann) t
s
renderTypAnnot Maybe [Char]
Nothing    t
s = t
s

renderErrAnnot :: (PrintfArg t1, PrintfType t1) => Maybe t -> t1 -> t1
renderErrAnnot :: forall t1 t. (PrintfArg t1, PrintfType t1) => Maybe t -> t1 -> t1
renderErrAnnot (Just t
_) t1
s   = forall r. PrintfType r => [Char] -> r
printf [Char]
"<span class=hs-error>%s</span>" t1
s
renderErrAnnot Maybe t
Nothing  t1
s   = t1
s

renderLinAnnot :: (Show t, PrintfArg t1, PrintfType t1)
               => Maybe (t, Int) -> t1 -> t1
renderLinAnnot :: forall t t1.
(Show t, PrintfArg t1, PrintfType t1) =>
Maybe (t, Int) -> t1 -> t1
renderLinAnnot (Just (t, Int)
d) t1
s   = forall r. PrintfType r => [Char] -> r
printf [Char]
"<span class=hs-linenum>%s: </span>%s" (forall t. Show t => (t, Int) -> [Char]
lineString (t, Int)
d) t1
s
renderLinAnnot Maybe (t, Int)
Nothing  t1
s   = t1
s

lineString :: Show t => (t, Int) -> [Char]
lineString :: forall t. Show t => (t, Int) -> [Char]
lineString (t
i, Int
w) = forall a. Int -> a -> [a]
replicate (Int
w forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
is) Char
' ' forall a. [a] -> [a] -> [a]
++ [Char]
is
  where is :: [Char]
is        = forall a. Show a => a -> [Char]
show t
i

{- 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, [Char], a)] -> [Either [Char] (TokenType, [Char], a)]
insertAnnotAnchors [(TokenType, [Char], a)]
toks
  = forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
stitch (forall a b. [a] -> [b] -> [(a, b)]
zip [(TokenType, [Char])]
toks' [(TokenType, [Char], a)]
toks) forall a b. (a -> b) -> a -> b
$ [(TokenType, [Char])] -> [Either [Char] (TokenType, [Char])]
insertAnchors [(TokenType, [Char])]
toks'
  where toks' :: [(TokenType, [Char])]
toks' = [(TokenType
x,[Char]
y) | (TokenType
x,[Char]
y,a
_) <- [(TokenType, [Char], 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)
  = forall a b. a -> Either a b
Left a
a forall a. a -> [a] -> [a]
: 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 forall a. Eq a => a -> a -> Bool
== b
x'
  = forall a b. b -> Either a b
Right c
y forall a. a -> [a] -> [a]
: forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
stitch [(b, c)]
xys [Either a b]
rest
  | Bool
otherwise
  = forall a. Maybe SrcSpan -> [Char] -> a
panic forall a. Maybe a
Nothing [Char]
"stitch"
stitch [(b, c)]
_ []
  = []
stitch [(b, c)]
_ [Either a b]
_
  = forall a. Maybe SrcSpan -> [Char] -> a
impossible forall a. Maybe a
Nothing [Char]
"stitch: cannot happen"

splitSrcAndAnns ::  String -> (String, AnnMap)
splitSrcAndAnns :: [Char] -> ([Char], AnnMap)
splitSrcAndAnns [Char]
s =
  let ls :: [[Char]]
ls = [Char] -> [[Char]]
lines [Char]
s in
  case forall a. Eq a => a -> [a] -> Maybe Int
elemIndex [Char]
breakS [[Char]]
ls of
    Maybe Int
Nothing -> ([Char]
s, HashMap Loc ([Char], [Char])
-> [(Loc, Loc, [Char])]
-> Status
-> [(RealSrcSpan, ([Char], [Char]))]
-> AnnMap
Ann forall k v. HashMap k v
M.empty [] Status
Safe forall a. Monoid a => a
mempty)
    Just Int
i  -> ([Char]
src, AnnMap
ann)
               where ([[Char]]
codes, [Char]
_:[Char]
mname:[[Char]]
annots) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [[Char]]
ls
                     ann :: AnnMap
ann   = [Char] -> [Char] -> AnnMap
annotParse [Char]
mname forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]]
annots
                     src :: [Char]
src   = [[Char]] -> [Char]
unlines [[Char]]
codes

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

tokenModule :: [(TokenType, [Char])] -> Maybe [Char]
tokenModule :: [(TokenType, [Char])] -> Maybe [Char]
tokenModule [(TokenType, [Char])]
toks
  = do Int
i <- forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (TokenType
Keyword, [Char]
"module") [(TokenType, [Char])]
toks
       let ([(TokenType, [Char])]
_, [(TokenType, [Char])]
toks')  = forall a. Int -> [a] -> ([a], [a])
splitAt (Int
iforall a. Num a => a -> a -> a
+Int
2) [(TokenType, [Char])]
toks
       Int
j <- forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ((TokenType
Space forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(TokenType, [Char])]
toks'
       let ([(TokenType, [Char])]
toks'', [(TokenType, [Char])]
_) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
j [(TokenType, [Char])]
toks'
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(TokenType, [Char])]
toks''

breakS :: [Char]
breakS :: [Char]
breakS = [Char]
"MOUSEOVER ANNOTATIONS"

annotParse :: String -> String -> AnnMap
annotParse :: [Char] -> [Char] -> AnnMap
annotParse [Char]
mname [Char]
s = HashMap Loc ([Char], [Char])
-> [(Loc, Loc, [Char])]
-> Status
-> [(RealSrcSpan, ([Char], [Char]))]
-> AnnMap
Ann (forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Loc, ([Char], [Char]))]
ts) [(Loc
x,Loc
y,[Char]
"") | (Loc
x,Loc
y) <- [(Loc, Loc)]
es] Status
Safe forall a. Monoid a => a
mempty
  where
    ([(Loc, ([Char], [Char]))]
ts, [(Loc, Loc)]
es)       = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ [Char]
-> Int -> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines [Char]
mname Int
0 forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
s


parseLines :: [Char]
           -> Int
           -> [[Char]]
           -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines :: [Char]
-> Int -> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines [Char]
_ Int
_ []
  = []

parseLines [Char]
mname Int
i ([Char]
"":[[Char]]
ls)
  = [Char]
-> Int -> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines [Char]
mname (Int
iforall a. Num a => a -> a -> a
+Int
1) [[Char]]
ls

parseLines [Char]
mname Int
i ([Char]
_:[Char]
_:[Char]
l:[Char]
c:[Char]
"0":[Char]
l':[Char]
c':[[Char]]
rest')
  = forall a b. b -> Either a b
Right ((Int, Int) -> Loc
L (Int
line, Int
col), (Int, Int) -> Loc
L (Int
line', Int
col')) forall a. a -> [a] -> [a]
: [Char]
-> Int -> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines [Char]
mname (Int
i forall a. Num a => a -> a -> a
+ Int
7) [[Char]]
rest'
    where line :: Int
line  = forall a. Read a => [Char] -> a
read [Char]
l  :: Int
          col :: Int
col   = forall a. Read a => [Char] -> a
read [Char]
c  :: Int
          line' :: Int
line' = forall a. Read a => [Char] -> a
read [Char]
l' :: Int
          col' :: Int
col'  = forall a. Read a => [Char] -> a
read [Char]
c' :: Int

parseLines [Char]
mname Int
i ([Char]
x:[Char]
f:[Char]
l:[Char]
c:[Char]
n:[[Char]]
rest)
  | [Char]
f forall a. Eq a => a -> a -> Bool
/= [Char]
mname
  = [Char]
-> Int -> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines [Char]
mname (Int
i forall a. Num a => a -> a -> a
+ Int
5 forall a. Num a => a -> a -> a
+ Int
num) [[Char]]
rest'
  | Bool
otherwise
  = forall a b. a -> Either a b
Left ((Int, Int) -> Loc
L (Int
line, Int
col), ([Char]
x, [Char]
anns)) forall a. a -> [a] -> [a]
: [Char]
-> Int -> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines [Char]
mname (Int
i forall a. Num a => a -> a -> a
+ Int
5 forall a. Num a => a -> a -> a
+ Int
num) [[Char]]
rest'
    where line :: Int
line  = forall a. Read a => [Char] -> a
read [Char]
l :: Int
          col :: Int
col   = forall a. Read a => [Char] -> a
read [Char]
c :: Int
          num :: Int
num   = forall a. Read a => [Char] -> a
read [Char]
n :: Int
          anns :: [Char]
anns  = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
num [[Char]]
rest
          rest' :: [[Char]]
rest' = forall a. Int -> [a] -> [a]
drop Int
num [[Char]]
rest

parseLines [Char]
_ Int
i [[Char]]
_
  = forall a. Maybe SrcSpan -> [Char] -> a
panic forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ [Char]
"Error Parsing Annot Input on Line: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
i

instance Show AnnMap where
  show :: AnnMap -> [Char]
show (Ann HashMap Loc ([Char], [Char])
ts [(Loc, Loc, [Char])]
es Status
_ [(RealSrcSpan, ([Char], [Char]))]
_) =  [Char]
"\n\n"
                      forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall t t1.
(PrintfArg t, PrintfType t1) =>
(Loc, (t, [Char])) -> t1
ppAnnotTyp (forall k v. HashMap k v -> [(k, v)]
M.toList HashMap Loc ([Char], [Char])
ts)
                      forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall t. PrintfType t => (Loc, Loc) -> t
ppAnnotErr [(Loc
x,Loc
y) | (Loc
x,Loc
y,[Char]
_) <- [(Loc, Loc, [Char])]
es]

ppAnnotTyp :: (PrintfArg t, PrintfType t1) => (Loc, (t, String)) -> t1
ppAnnotTyp :: forall t t1.
(PrintfArg t, PrintfType t1) =>
(Loc, (t, [Char])) -> t1
ppAnnotTyp (L (Int
l, Int
c), (t
x, [Char]
s))     = forall r. PrintfType r => [Char] -> r
printf [Char]
"%s\n%d\n%d\n%d\n%s\n\n\n" t
x Int
l Int
c (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
s) [Char]
s

ppAnnotErr :: PrintfType t => (Loc, Loc) -> t
ppAnnotErr :: forall t. PrintfType t => (Loc, Loc) -> t
ppAnnotErr (L (Int
l, Int
c), L (Int
l', Int
c')) = forall r. PrintfType r => [Char] -> r
printf [Char]
" \n%d\n%d\n0\n%d\n%d\n\n\n\n" Int
l Int
c Int
l' Int
c'


---------------------------------------------------------------------------------
---- Code for Dealing With LHS, stolen from Language.Haskell.HsColour.HsColour --
---------------------------------------------------------------------------------

-- | Separating literate files into code\/comment chunks.
data Lit = Code {Lit -> [Char]
unL :: String} | Lit {unL :: String} deriving (Int -> Lit -> ShowS
[Lit] -> ShowS
Lit -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Lit] -> ShowS
$cshowList :: [Lit] -> ShowS
show :: Lit -> [Char]
$cshow :: Lit -> [Char]
showsPrec :: Int -> Lit -> ShowS
$cshowsPrec :: Int -> Lit -> ShowS
Show)

-- Re-implementation of 'lines', for better efficiency (but decreased laziness).
-- Also, importantly, accepts non-standard DOS and Mac line ending characters.
-- And retains the trailing '\n' character in each resultant string.
inlines :: String -> [String]
inlines :: [Char] -> [[Char]]
inlines [Char]
str = [Char] -> ShowS -> [[Char]]
lines' [Char]
str forall a. a -> a
id
  where
  lines' :: [Char] -> ShowS -> [[Char]]
lines' []             ShowS
acc = [ShowS
acc []]
  lines' (Char
'\^M':Char
'\n':[Char]
s) ShowS
acc = ShowS
acc [Char
'\n'] forall a. a -> [a] -> [a]
: [Char] -> ShowS -> [[Char]]
lines' [Char]
s forall a. a -> a
id  -- DOS
  lines' (Char
'\n':[Char]
s)       ShowS
acc = ShowS
acc [Char
'\n'] forall a. a -> [a] -> [a]
: [Char] -> ShowS -> [[Char]]
lines' [Char]
s forall a. a -> a
id  -- Unix
  lines' (Char
c:[Char]
s)          ShowS
acc = [Char] -> ShowS -> [[Char]]
lines' [Char]
s (ShowS
acc forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cforall a. a -> [a] -> [a]
:))


-- | The code for classify is largely stolen from Language.Preprocessor.Unlit.
classify ::  [String] -> [Lit]
classify :: [[Char]] -> [Lit]
classify []             = []
classify ([Char]
x:[[Char]]
xs) | [Char]
"\\begin{code}"forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`[Char]
x
                        = [Char] -> Lit
Lit [Char]
xforall a. a -> [a] -> [a]
: [Char] -> [[Char]] -> [Lit]
allProg [Char]
"code" [[Char]]
xs
classify ([Char]
x:[[Char]]
xs) | [Char]
"\\begin{spec}"forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`[Char]
x
                        = [Char] -> Lit
Lit [Char]
xforall a. a -> [a] -> [a]
: [Char] -> [[Char]] -> [Lit]
allProg [Char]
"spec" [[Char]]
xs
classify ((Char
'>':[Char]
x):[[Char]]
xs)   = [Char] -> Lit
Code (Char
'>'forall a. a -> [a] -> [a]
:[Char]
x) forall a. a -> [a] -> [a]
: [[Char]] -> [Lit]
classify [[Char]]
xs
classify ([Char]
x:[[Char]]
xs)         = [Char] -> Lit
Lit [Char]
xforall a. a -> [a] -> [a]
: [[Char]] -> [Lit]
classify [[Char]]
xs


allProg :: [Char] -> [[Char]] -> [Lit]
allProg :: [Char] -> [[Char]] -> [Lit]
allProg [Char]
name  = [[Char]] -> [Lit]
go
  where
    end :: [Char]
end       = [Char]
"\\end{" forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
"}"
    go :: [[Char]] -> [Lit]
go []     = []  -- Should give an error message,
                    -- but I have no good position information.
    go ([Char]
x:[[Char]]
xs) | [Char]
end `isPrefixOf `[Char]
x
              = [Char] -> Lit
Lit [Char]
xforall a. a -> [a] -> [a]
: [[Char]] -> [Lit]
classify [[Char]]
xs
    go ([Char]
x:[[Char]]
xs) = [Char] -> Lit
Code [Char]
xforall a. a -> [a] -> [a]
: [[Char]] -> [Lit]
go [[Char]]
xs


-- | Join up chunks of code\/comment that are next to each other.
joinL :: [Lit] -> [Lit]
joinL :: [Lit] -> [Lit]
joinL []                  = []
joinL (Code [Char]
c:Code [Char]
c2:[Lit]
xs) = [Lit] -> [Lit]
joinL ([Char] -> Lit
Code ([Char]
cforall a. [a] -> [a] -> [a]
++[Char]
c2)forall a. a -> [a] -> [a]
:[Lit]
xs)
joinL (Lit [Char]
c :Lit [Char]
c2 :[Lit]
xs) = [Lit] -> [Lit]
joinL ([Char] -> Lit
Lit  ([Char]
cforall a. [a] -> [a] -> [a]
++[Char]
c2)forall a. a -> [a] -> [a]
:[Lit]
xs)
joinL (Lit
lit:[Lit]
xs)            = Lit
litforall a. a -> [a] -> [a]
: [Lit] -> [Lit]
joinL [Lit]
xs