{-# 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
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
/= :: Status -> Status -> Bool
Eq, Eq Status
Eq Status =>
(Status -> Status -> Ordering)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Status)
-> (Status -> Status -> Status)
-> Ord 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
$ccompare :: Status -> Status -> Ordering
compare :: Status -> Status -> Ordering
$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
>= :: Status -> Status -> Bool
$cmax :: Status -> Status -> Status
max :: Status -> Status -> Status
$cmin :: Status -> Status -> Status
min :: Status -> Status -> Status
Ord, Int -> Status -> ShowS
[Status] -> ShowS
Status -> [Char]
(Int -> Status -> ShowS)
-> (Status -> [Char]) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Status -> ShowS
showsPrec :: Int -> Status -> ShowS
$cshow :: Status -> [Char]
show :: Status -> [Char]
$cshowList :: [Status] -> ShowS
showList :: [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]
(Int -> Annotation -> ShowS)
-> (Annotation -> [Char])
-> ([Annotation] -> ShowS)
-> Show Annotation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Annotation -> ShowS
showsPrec :: Int -> Annotation -> ShowS
$cshow :: Annotation -> [Char]
show :: Annotation -> [Char]
$cshowList :: [Annotation] -> ShowS
showList :: [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 CommentTransform
forall a. Maybe a
Nothing Bool
lhs (([Char], AnnMap) -> [Char])
-> ([Char] -> ([Char], AnnMap)) -> ShowS
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' Maybe Loc
forall a. Maybe a
Nothing Bool
anchor CommentTransform
tx ([Char], AnnMap)
z
hsannot Bool
anchor CommentTransform
tx Bool
True ([Char]
s, AnnMap
m) = ((Lit, Loc) -> [Char]) -> [(Lit, Loc)] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Lit, Loc) -> [Char]
chunk ([(Lit, Loc)] -> [Char]) -> [(Lit, Loc)] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Lit] -> [(Lit, Loc)]
litSpans ([Lit] -> [(Lit, Loc)]) -> [Lit] -> [(Lit, Loc)]
forall a b. (a -> b) -> a -> b
$ [Lit] -> [Lit]
joinL ([Lit] -> [Lit]) -> [Lit] -> [Lit]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Lit]
classify ([[Char]] -> [Lit]) -> [[Char]] -> [Lit]
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' (Loc -> Maybe Loc
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 = [Lit] -> [Loc] -> [(Lit, Loc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Lit]
lits ([Loc] -> [(Lit, Loc)]) -> [Loc] -> [(Lit, Loc)]
forall a b. (a -> b) -> a -> b
$ [Lit] -> [Loc]
spans [Lit]
lits
  where spans :: [Lit] -> [Loc]
spans = Maybe Loc -> [[Char]] -> [Loc]
tokenSpans Maybe Loc
forall a. Maybe a
Nothing ([[Char]] -> [Loc]) -> ([Lit] -> [[Char]]) -> [Lit] -> [Loc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lit -> [Char]) -> [Lit] -> [[Char]]
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
    ShowS -> (([Char], AnnMap) -> [Char]) -> ([Char], AnnMap) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
anchor then (Either [Char] (TokenType, [Char], Annotation) -> [Char])
-> [Either [Char] (TokenType, [Char], Annotation)] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((TokenType, [Char], Annotation) -> [Char])
-> Either [Char] (TokenType, [Char], Annotation) -> [Char]
forall a. (a -> [Char]) -> Either [Char] a -> [Char]
renderAnchors (TokenType, [Char], Annotation) -> [Char]
renderAnnotToken)
                      ([Either [Char] (TokenType, [Char], Annotation)] -> [Char])
-> ([(TokenType, [Char], Annotation)]
    -> [Either [Char] (TokenType, [Char], Annotation)])
-> [(TokenType, [Char], Annotation)]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenType, [Char], Annotation)]
-> [Either [Char] (TokenType, [Char], Annotation)]
forall a.
[(TokenType, [Char], a)] -> [Either [Char] (TokenType, [Char], a)]
insertAnnotAnchors
                 else ((TokenType, [Char], Annotation) -> [Char])
-> [(TokenType, [Char], Annotation)] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TokenType, [Char], Annotation) -> [Char]
renderAnnotToken)
    ([(TokenType, [Char], Annotation)] -> [Char])
-> (([Char], AnnMap) -> [(TokenType, [Char], Annotation)])
-> ([Char], AnnMap)
-> [Char]
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 = ((TokenType, [Char]) -> Loc -> (TokenType, [Char], Loc))
-> [(TokenType, [Char])] -> [Loc] -> [(TokenType, [Char], Loc)]
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 Maybe Loc
forall a. Maybe a
Nothing ([[Char]] -> [Loc]) -> [[Char]] -> [Loc]
forall a b. (a -> b) -> a -> b
$ ((TokenType, [Char]) -> [Char])
-> [(TokenType, [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (TokenType, [Char]) -> [Char]
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) = ((TokenType, [Char])
 -> Annotation -> (TokenType, [Char], Annotation))
-> [(TokenType, [Char])]
-> [Annotation]
-> [(TokenType, [Char], Annotation)]
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 ([[Char]] -> [Loc]) -> [[Char]] -> [Loc]
forall a b. (a -> b) -> a -> b
$ ((TokenType, [Char]) -> [Char])
-> [(TokenType, [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (TokenType, [Char]) -> [Char]
forall a b. (a, b) -> b
snd [(TokenType, [Char])]
toks
    annots :: [Annotation]
annots     = (Loc -> Annotation) -> [Loc] -> [Annotation]
forall a b. (a -> b) -> [a] -> [b]
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   = [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char] -> Int) -> [Char] -> Int
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Char]] -> Int) -> [[Char]] -> Int
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 = (([Char], [Char]) -> [Char])
-> Maybe ([Char], [Char]) -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd (Loc -> HashMap Loc ([Char], [Char]) -> Maybe ([Char], [Char])
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" [Char] -> Maybe (Loc, Loc) -> Maybe [Char]
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((Loc, Loc) -> Bool) -> [(Loc, Loc)] -> Maybe (Loc, Loc)
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 = Int -> Loc -> Maybe (Int, Int)
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1    = (Int, t) -> Maybe (Int, t)
forall a. a -> Maybe a
Just (Int
l, t
w)
  | Bool
otherwise = Maybe (Int, t)
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
l0 Bool -> Bool -> Bool
&& Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
c0 Bool -> Bool -> Bool
&& Int
l0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
l' Bool -> Bool -> Bool
&& Int
c0 Int -> Int -> Bool
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) = ((TokenType, [Char]) -> [(TokenType, [Char])])
-> [(TokenType, [Char])] -> [(TokenType, [Char])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char] -> [(TokenType, [Char])])
-> (TokenType, [Char]) -> [(TokenType, [Char])]
forall {t}.
(t -> [(TokenType, t)]) -> (TokenType, t) -> [(TokenType, t)]
expand [Char] -> [(TokenType, [Char])]
g) ([(TokenType, [Char])] -> [(TokenType, [Char])])
-> ([Char] -> [(TokenType, [Char])])
-> [Char]
-> [(TokenType, [Char])]
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 = (Loc -> [Char] -> Loc) -> Loc -> [[Char]] -> [Loc]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Loc -> [Char] -> Loc
plusLoc (Loc -> [[Char]] -> [Loc])
-> (Maybe Loc -> Loc) -> Maybe Loc -> [[Char]] -> [Loc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> Maybe Loc -> Loc
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' Char -> [Char] -> [Int]
forall a. Eq a => a -> [a] -> [Int]
`elemIndices` [Char]
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 = [Char] -> Int
forall a. [a] -> Int
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)  = Maybe (Int, Int) -> ShowS
forall t t1.
(Show t, PrintfArg t1, PrintfType t1) =>
Maybe (t, Int) -> t1 -> t1
renderLinAnnot (Annotation -> Maybe (Int, Int)
lin Annotation
a)
                            ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> ShowS
forall t1 t. (PrintfArg t1, PrintfType t1) => Maybe t -> t1 -> t1
renderErrAnnot (Annotation -> Maybe [Char]
err Annotation
a)
                            ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> ShowS
forall t. (PrintfArg t, PrintfType t) => Maybe [Char] -> t -> t
renderTypAnnot (Annotation -> Maybe [Char]
typ Annotation
a)
                            ShowS -> ShowS
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 = [Char] -> [Char] -> t -> t
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   = [Char] -> t1 -> t1
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   = [Char] -> [Char] -> t1 -> t1
forall r. PrintfType r => [Char] -> r
printf [Char]
"<span class=hs-linenum>%s: </span>%s" ((t, Int) -> [Char]
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) = Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
is) Char
' ' [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
is
  where is :: [Char]
is        = t -> [Char]
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
  = [((TokenType, [Char]), (TokenType, [Char], a))]
-> [Either [Char] (TokenType, [Char])]
-> [Either [Char] (TokenType, [Char], a)]
forall b c a. Eq b => [(b, c)] -> [Either a b] -> [Either a c]
stitch ([(TokenType, [Char])]
-> [(TokenType, [Char], a)]
-> [((TokenType, [Char]), (TokenType, [Char], a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(TokenType, [Char])]
toks' [(TokenType, [Char], a)]
toks) ([Either [Char] (TokenType, [Char])]
 -> [Either [Char] (TokenType, [Char], a)])
-> [Either [Char] (TokenType, [Char])]
-> [Either [Char] (TokenType, [Char], a)]
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)
  = 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
  = Maybe SrcSpan -> [Char] -> [Either a c]
forall a. HasCallStack => Maybe SrcSpan -> [Char] -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing [Char]
"stitch"
stitch [(b, c)]
_ []
  = []
stitch [(b, c)]
_ [Either a b]
_
  = Maybe SrcSpan -> [Char] -> [Either a c]
forall a. Maybe SrcSpan -> [Char] -> a
impossible Maybe SrcSpan
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 [Char] -> [[Char]] -> Maybe Int
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 HashMap Loc ([Char], [Char])
forall k v. HashMap k v
M.empty [] Status
Safe [(RealSrcSpan, ([Char], [Char]))]
forall a. Monoid a => a
mempty)
    Just Int
i  -> ([Char]
src, AnnMap
ann)
               where ([[Char]]
codes, [Char]
_:[Char]
mname:[[Char]]
annots) = Int -> [[Char]] -> ([[Char]], [[Char]])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [[Char]]
ls
                     ann :: AnnMap
ann   = [Char] -> [Char] -> AnnMap
annotParse [Char]
mname ([Char] -> AnnMap) -> [Char] -> AnnMap
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS
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 = [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"Main" (Maybe [Char] -> [Char]) -> ([Char] -> Maybe [Char]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TokenType, [Char])] -> Maybe [Char]
tokenModule ([(TokenType, [Char])] -> Maybe [Char])
-> ([Char] -> [(TokenType, [Char])]) -> [Char] -> Maybe [Char]
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 i <- (TokenType, [Char]) -> [(TokenType, [Char])] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (TokenType
Keyword, [Char]
"module") [(TokenType, [Char])]
toks
       let (_, toks')  = splitAt (i+2) toks
       j <- findIndex ((Space ==) . fst) toks'
       let (toks'', _) = splitAt j toks'
       return $ concatMap snd 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 ([(Loc, ([Char], [Char]))] -> HashMap Loc ([Char], [Char])
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 [(RealSrcSpan, ([Char], [Char]))]
forall a. Monoid a => a
mempty
  where
    ([(Loc, ([Char], [Char]))]
ts, [(Loc, Loc)]
es)       = [Either (Loc, ([Char], [Char])) (Loc, Loc)]
-> ([(Loc, ([Char], [Char]))], [(Loc, Loc)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (Loc, ([Char], [Char])) (Loc, Loc)]
 -> ([(Loc, ([Char], [Char]))], [(Loc, Loc)]))
-> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
-> ([(Loc, ([Char], [Char]))], [(Loc, Loc)])
forall a b. (a -> b) -> a -> b
$ [Char]
-> Int -> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines [Char]
mname Int
0 ([[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)])
-> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
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
iInt -> Int -> Int
forall 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')
  = (Loc, Loc) -> Either (Loc, ([Char], [Char])) (Loc, Loc)
forall a b. b -> Either a b
Right ((Int, Int) -> Loc
L (Int
line, Int
col), (Int, Int) -> Loc
L (Int
line', Int
col')) Either (Loc, ([Char], [Char])) (Loc, Loc)
-> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
-> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
forall a. a -> [a] -> [a]
: [Char]
-> Int -> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines [Char]
mname (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) [[Char]]
rest'
    where line :: Int
line  = [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
l  :: Int
          col :: Int
col   = [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
c  :: Int
          line' :: Int
line' = [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
l' :: Int
          col' :: Int
col'  = [Char] -> Int
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 [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
mname
  = [Char]
-> Int -> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines [Char]
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) [[Char]]
rest'
  | Bool
otherwise
  = (Loc, ([Char], [Char]))
-> Either (Loc, ([Char], [Char])) (Loc, Loc)
forall a b. a -> Either a b
Left ((Int, Int) -> Loc
L (Int
line, Int
col), ([Char]
x, [Char]
anns)) Either (Loc, ([Char], [Char])) (Loc, Loc)
-> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
-> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
forall a. a -> [a] -> [a]
: [Char]
-> Int -> [[Char]] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
parseLines [Char]
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) [[Char]]
rest'
    where line :: Int
line  = [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
l :: Int
          col :: Int
col   = [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
c :: Int
          num :: Int
num   = [Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
n :: Int
          anns :: [Char]
anns  = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
take Int
num [[Char]]
rest
          rest' :: [[Char]]
rest' = Int -> [[Char]] -> [[Char]]
forall a. Int -> [a] -> [a]
drop Int
num [[Char]]
rest

parseLines [Char]
_ Int
i [[Char]]
_
  = Maybe SrcSpan
-> [Char] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
forall a. HasCallStack => Maybe SrcSpan -> [Char] -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing ([Char] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)])
-> [Char] -> [Either (Loc, ([Char], [Char])) (Loc, Loc)]
forall a b. (a -> b) -> a -> b
$ [Char]
"Error Parsing Annot Input on Line: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
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"
                      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Loc, ([Char], [Char])) -> [Char])
-> [(Loc, ([Char], [Char]))] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Loc, ([Char], [Char])) -> [Char]
forall t t1.
(PrintfArg t, PrintfType t1) =>
(Loc, (t, [Char])) -> t1
ppAnnotTyp (HashMap Loc ([Char], [Char]) -> [(Loc, ([Char], [Char]))]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap Loc ([Char], [Char])
ts)
                      [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Loc, Loc) -> [Char]) -> [(Loc, Loc)] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Loc, Loc) -> [Char]
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))     = [Char] -> t -> Int -> Int -> Int -> [Char] -> t1
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 ([[Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Char]] -> Int) -> [[Char]] -> Int
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')) = [Char] -> Int -> Int -> Int -> Int -> t
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]
(Int -> Lit -> ShowS)
-> (Lit -> [Char]) -> ([Lit] -> ShowS) -> Show Lit
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Lit -> ShowS
showsPrec :: Int -> Lit -> ShowS
$cshow :: Lit -> [Char]
show :: Lit -> [Char]
$cshowList :: [Lit] -> ShowS
showList :: [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 ShowS
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'] [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> ShowS -> [[Char]]
lines' [Char]
s ShowS
forall a. a -> a
id  -- DOS
  lines' (Char
'\n':[Char]
s)       ShowS
acc = ShowS
acc [Char
'\n'] [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> ShowS -> [[Char]]
lines' [Char]
s ShowS
forall a. a -> a
id  -- Unix
  lines' (Char
c:[Char]
s)          ShowS
acc = [Char] -> ShowS -> [[Char]]
lines' [Char]
s (ShowS
acc ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> ShowS
forall 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}"[Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`[Char]
x
                        = [Char] -> Lit
Lit [Char]
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]] -> [Lit]
allProg [Char]
"code" [[Char]]
xs
classify ([Char]
x:[[Char]]
xs) | [Char]
"\\begin{spec}"[Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`[Char]
x
                        = [Char] -> Lit
Lit [Char]
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]] -> [Lit]
allProg [Char]
"spec" [[Char]]
xs
classify ((Char
'>':[Char]
x):[[Char]]
xs)   = [Char] -> Lit
Code (Char
'>'Char -> ShowS
forall a. a -> [a] -> [a]
:[Char]
x) Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [[Char]] -> [Lit]
classify [[Char]]
xs
classify ([Char]
x:[[Char]]
xs)         = [Char] -> Lit
Lit [Char]
xLit -> [Lit] -> [Lit]
forall 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{" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> ShowS
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]
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [[Char]] -> [Lit]
classify [[Char]]
xs
    go ([Char]
x:[[Char]]
xs) = [Char] -> Lit
Code [Char]
xLit -> [Lit] -> [Lit]
forall 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]
c[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
c2)Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
:[Lit]
xs)
joinL (Lit [Char]
c :Lit [Char]
c2 :[Lit]
xs) = [Lit] -> [Lit]
joinL ([Char] -> Lit
Lit  ([Char]
c[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
c2)Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
:[Lit]
xs)
joinL (Lit
lit:[Lit]
xs)            = Lit
litLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [Lit] -> [Lit]
joinL [Lit]
xs