-- | 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 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)
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 (String, String)
types   :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type)
  , AnnMap -> [(Loc, Loc, String)]
errors  :: [(Loc, Loc, String)]           -- ^ List of error intervals
  , AnnMap -> Status
status  :: !Status
  , AnnMap -> [(RealSrcSpan, (String, String))]
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
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: 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
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
$cp1Ord :: Eq Status
Ord, Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show)

data Annotation = A {
    Annotation -> Maybe String
typ :: Maybe String         -- ^ type  string
  , Annotation -> Maybe String
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 -> String
(Int -> Annotation -> ShowS)
-> (Annotation -> String)
-> ([Annotation] -> ShowS)
-> Show Annotation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Annotation] -> ShowS
$cshowList :: [Annotation] -> ShowS
show :: Annotation -> String
$cshow :: Annotation -> String
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 -> (String, AnnMap) -> String
hsannot Bool
anchor CommentTransform
forall a. Maybe a
Nothing Bool
lhs ((String, AnnMap) -> String)
-> (String -> (String, AnnMap)) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, 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 -> (String, AnnMap) -> String
hsannot Bool
anchor CommentTransform
tx Bool
False (String, AnnMap)
z     = Maybe Loc -> Bool -> CommentTransform -> (String, AnnMap) -> String
hsannot' Maybe Loc
forall a. Maybe a
Nothing Bool
anchor CommentTransform
tx (String, AnnMap)
z
hsannot Bool
anchor CommentTransform
tx Bool
True (String
s, AnnMap
m) = ((Lit, Loc) -> String) -> [(Lit, Loc)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Lit, Loc) -> String
chunk ([(Lit, Loc)] -> String) -> [(Lit, Loc)] -> String
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
$ [String] -> [Lit]
classify ([String] -> [Lit]) -> [String] -> [Lit]
forall a b. (a -> b) -> a -> b
$ String -> [String]
inlines String
s
  where chunk :: (Lit, Loc) -> String
chunk (Code String
c, Loc
l)     = Maybe Loc -> Bool -> CommentTransform -> (String, AnnMap) -> String
hsannot' (Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
l) Bool
anchor CommentTransform
tx (String
c, AnnMap
m)
        chunk (Lit String
c , Loc
_)     = String
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 -> [String] -> [Loc]
tokenSpans Maybe Loc
forall a. Maybe a
Nothing ([String] -> [Loc]) -> ([Lit] -> [String]) -> [Lit] -> [Loc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lit -> String) -> [Lit] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Lit -> String
unL

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

tokeniseWithLoc :: CommentTransform -> String -> [(TokenType, String, Loc)]
tokeniseWithLoc :: CommentTransform -> String -> [(TokenType, String, Loc)]
tokeniseWithLoc CommentTransform
tx String
str = ((TokenType, String) -> Loc -> (TokenType, String, Loc))
-> [(TokenType, String)] -> [Loc] -> [(TokenType, String, Loc)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(TokenType
x,String
y) Loc
z -> (TokenType
x, String
y, Loc
z)) [(TokenType, String)]
toks [Loc]
spans  
  where
    toks :: [(TokenType, String)]
toks       = CommentTransform -> String -> [(TokenType, String)]
tokeniseWithCommentTransform CommentTransform
tx String
str
    spans :: [Loc]
spans      = Maybe Loc -> [String] -> [Loc]
tokenSpans Maybe Loc
forall a. Maybe a
Nothing ([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

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

annotTokenise :: Maybe Loc -> CommentTransform -> (String, AnnMap) -> [(TokenType, String, Annotation)]
annotTokenise :: Maybe Loc
-> CommentTransform
-> (String, AnnMap)
-> [(TokenType, String, Annotation)]
annotTokenise Maybe Loc
baseLoc CommentTransform
tx (String
src, AnnMap
annm) = ((TokenType, String)
 -> Annotation -> (TokenType, String, Annotation))
-> [(TokenType, String)]
-> [Annotation]
-> [(TokenType, String, Annotation)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(TokenType
x,String
y) Annotation
z -> (TokenType
x,String
y,Annotation
z)) [(TokenType, String)]
toks [Annotation]
annots
  where
    toks :: [(TokenType, String)]
toks       = CommentTransform -> String -> [(TokenType, String)]
tokeniseWithCommentTransform CommentTransform
tx String
src
    spans :: [Loc]
spans      = Maybe Loc -> [String] -> [Loc]
tokenSpans Maybe Loc
baseLoc ([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 :: [Annotation]
annots     = (Loc -> Annotation) -> [Loc] -> [Annotation]
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   = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [String] -> 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
src

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

spanLine :: t -> Loc -> Maybe (Int, t)
spanLine :: 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 -> String -> [(TokenType, String)]
tokeniseWithCommentTransform CommentTransform
Nothing  = String -> [(TokenType, String)]
tokenise
tokeniseWithCommentTransform (Just String -> [(TokenType, String)]
f) = ((TokenType, String) -> [(TokenType, String)])
-> [(TokenType, String)] -> [(TokenType, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> [(TokenType, String)])
-> (TokenType, String) -> [(TokenType, String)]
forall t.
(t -> [(TokenType, t)]) -> (TokenType, t) -> [(TokenType, t)]
expand String -> [(TokenType, String)]
f) ([(TokenType, String)] -> [(TokenType, String)])
-> (String -> [(TokenType, String)])
-> String
-> [(TokenType, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(TokenType, String)]
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 -> [String] -> [Loc]
tokenSpans = (Loc -> String -> Loc) -> Loc -> [String] -> [Loc]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Loc -> String -> Loc
plusLoc (Loc -> [String] -> [Loc])
-> (Maybe Loc -> Loc) -> Maybe Loc -> [String] -> [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 -> 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 (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 (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
is))
    where n :: Int
n = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s

renderAnnotToken :: (TokenType, String, Annotation) -> String
renderAnnotToken :: (TokenType, String, Annotation) -> String
renderAnnotToken (TokenType
x, String
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 String -> ShowS
forall t1 t. (PrintfArg t1, PrintfType t1) => Maybe t -> t1 -> t1
renderErrAnnot (Annotation -> Maybe String
err Annotation
a)
                            ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Maybe String -> ShowS
forall t. (PrintfArg t, PrintfType t) => Maybe String -> t -> t
renderTypAnnot (Annotation -> Maybe String
typ Annotation
a)
                            ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (TokenType, String) -> String
CSS.renderToken (TokenType
x, String
y)



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

renderErrAnnot :: (PrintfArg t1, PrintfType t1) => Maybe t -> t1 -> t1
renderErrAnnot :: Maybe t -> t1 -> t1
renderErrAnnot (Just t
_) t1
s   = String -> t1 -> t1
forall r. PrintfType r => String -> r
printf String
"<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 :: Maybe (t, Int) -> t1 -> t1
renderLinAnnot (Just (t, Int)
d) t1
s   = String -> String -> t1 -> t1
forall r. PrintfType r => String -> r
printf String
"<span class=hs-linenum>%s: </span>%s" ((t, Int) -> String
forall t. Show t => (t, Int) -> String
lineString (t, Int)
d) t1
s
renderLinAnnot Maybe (t, Int)
Nothing  t1
s   = t1
s

lineString :: Show t => (t, Int) -> [Char]
lineString :: (t, Int) -> String
lineString (t
i, Int
w) = (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
is)) Char
' ') String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
is
  where is :: String
is        = t -> String
forall a. Show a => a -> String
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 :: [(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 :: [(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 -> String -> [Either a c]
forall a. Maybe SrcSpan -> String -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing String
"stitch"
stitch [(b, c)]
_ []
  = []
stitch [(b, c)]
_ [Either a b]
_
  = Maybe SrcSpan -> String -> [Either a c]
forall a. Maybe SrcSpan -> String -> a
impossible Maybe SrcSpan
forall a. Maybe a
Nothing String
"stitch: cannot happen"

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, HashMap Loc (String, String)
-> [(Loc, Loc, String)]
-> Status
-> [(RealSrcSpan, (String, String))]
-> AnnMap
Ann HashMap Loc (String, String)
forall k v. HashMap k v
M.empty [] Status
Safe [(RealSrcSpan, (String, String))]
forall a. Monoid a => a
mempty)
    Just Int
i  -> (String
src, 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) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
annots
                     src :: String
src   = [String] -> String
unlines [String]
codes

srcModuleName :: String -> String
srcModuleName :: ShowS
srcModuleName = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Main" (Maybe String -> String) -> (String -> Maybe String) -> ShowS
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, [Char])] -> Maybe [Char]
tokenModule :: [(TokenType, String)] -> Maybe String
tokenModule [(TokenType, String)]
toks
  = do Int
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 ([(TokenType, String)]
_, [(TokenType, String)]
toks')  = Int
-> [(TokenType, String)]
-> ([(TokenType, String)], [(TokenType, String)])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) [(TokenType, String)]
toks
       Int
j <- ((TokenType, String) -> Bool) -> [(TokenType, String)] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex ((TokenType
Space TokenType -> TokenType -> Bool
forall a. Eq a => a -> a -> Bool
==) (TokenType -> Bool)
-> ((TokenType, String) -> TokenType)
-> (TokenType, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenType, String) -> TokenType
forall a b. (a, b) -> a
fst) [(TokenType, String)]
toks'
       let ([(TokenType, String)]
toks'', [(TokenType, String)]
_) = Int
-> [(TokenType, String)]
-> ([(TokenType, String)], [(TokenType, String)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
j [(TokenType, String)]
toks'
       String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ((TokenType, String) -> String) -> [(TokenType, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TokenType, String) -> String
forall a b. (a, b) -> b
snd [(TokenType, String)]
toks''

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

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


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

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

parseLines String
mname Int
i (String
_:String
_:String
l:String
c:String
"0":String
l':String
c':[String]
rest')
  = (Loc, Loc) -> Either (Loc, (String, String)) (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, (String, String)) (Loc, Loc)
-> [Either (Loc, (String, String)) (Loc, Loc)]
-> [Either (Loc, (String, String)) (Loc, Loc)]
forall a. a -> [a] -> [a]
: String
-> Int -> [String] -> [Either (Loc, (String, String)) (Loc, Loc)]
parseLines String
mname (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) [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
          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

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
  = String
-> Int -> [String] -> [Either (Loc, (String, String)) (Loc, Loc)]
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
  = (Loc, (String, String))
-> Either (Loc, (String, String)) (Loc, Loc)
forall a b. a -> Either a b
Left ((Int, Int) -> Loc
L (Int
line, Int
col), (String
x, String
anns)) Either (Loc, (String, String)) (Loc, Loc)
-> [Either (Loc, (String, String)) (Loc, Loc)]
-> [Either (Loc, (String, String)) (Loc, Loc)]
forall a. a -> [a] -> [a]
: String
-> Int -> [String] -> [Either (Loc, (String, String)) (Loc, Loc)]
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]
_
  = Maybe SrcSpan
-> String -> [Either (Loc, (String, String)) (Loc, Loc)]
forall a. Maybe SrcSpan -> String -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing (String -> [Either (Loc, (String, String)) (Loc, Loc)])
-> String -> [Either (Loc, (String, String)) (Loc, Loc)]
forall a b. (a -> b) -> a -> b
$ String
"Error Parsing Annot Input on Line: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

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

ppAnnotTyp :: (PrintfArg t, PrintfType t1) => (Loc, (t, String)) -> t1
ppAnnotTyp :: (Loc, (t, String)) -> t1
ppAnnotTyp (L (Int
l, Int
c), (t
x, String
s))     = String -> t -> Int -> Int -> Int -> String -> t1
forall r. PrintfType r => String -> r
printf String
"%s\n%d\n%d\n%d\n%s\n\n\n" t
x Int
l Int
c ([String] -> 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
s

ppAnnotErr :: PrintfType t => (Loc, Loc) -> t
ppAnnotErr :: (Loc, Loc) -> t
ppAnnotErr (L (Int
l, Int
c), L (Int
l', Int
c')) = String -> Int -> Int -> Int -> Int -> t
forall r. PrintfType r => String -> r
printf String
" \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 -> String
unL :: String} | Lit {unL :: String} deriving (Int -> Lit -> ShowS
[Lit] -> ShowS
Lit -> String
(Int -> Lit -> ShowS)
-> (Lit -> String) -> ([Lit] -> ShowS) -> Show Lit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Lit] -> ShowS
$cshowList :: [Lit] -> ShowS
show :: Lit -> String
$cshow :: Lit -> String
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 :: String -> [String]
inlines String
s = String -> ShowS -> [String]
lines' String
s ShowS
forall a. a -> a
id
  where
  lines' :: String -> ShowS -> [String]
lines' []             ShowS
acc = [ShowS
acc []]
  lines' (Char
'\^M':Char
'\n':String
s) ShowS
acc = ShowS
acc [Char
'\n'] String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> ShowS -> [String]
lines' String
s ShowS
forall a. a -> a
id  -- DOS
  lines' (Char
'\n':String
s)       ShowS
acc = ShowS
acc [Char
'\n'] String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> ShowS -> [String]
lines' String
s ShowS
forall a. a -> a
id  -- Unix
  lines' (Char
c:String
s)          ShowS
acc = String -> ShowS -> [String]
lines' String
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 :: [String] -> [Lit]
classify []             = []
classify (String
x:[String]
xs) | String
"\\begin{code}"String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`String
x
                        = String -> Lit
Lit String
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: String -> [String] -> [Lit]
allProg String
"code" [String]
xs
classify (String
x:[String]
xs) | String
"\\begin{spec}"String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`String
x
                        = String -> Lit
Lit String
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: String -> [String] -> [Lit]
allProg String
"spec" [String]
xs
classify ((Char
'>':String
x):[String]
xs)   = String -> Lit
Code (Char
'>'Char -> ShowS
forall a. a -> [a] -> [a]
:String
x) Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [String] -> [Lit]
classify [String]
xs
classify (String
x:[String]
xs)         = String -> Lit
Lit String
xLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [String] -> [Lit]
classify [String]
xs


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


-- | Join up chunks of code\/comment that are next to each other.
joinL :: [Lit] -> [Lit]
joinL :: [Lit] -> [Lit]
joinL []                  = []
joinL (Code String
c:Code String
c2:[Lit]
xs) = [Lit] -> [Lit]
joinL (String -> Lit
Code (String
cString -> ShowS
forall a. [a] -> [a] -> [a]
++String
c2)Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
:[Lit]
xs)
joinL (Lit String
c :Lit String
c2 :[Lit]
xs) = [Lit] -> [Lit]
joinL (String -> Lit
Lit  (String
cString -> ShowS
forall a. [a] -> [a] -> [a]
++String
c2)Lit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
:[Lit]
xs)
joinL (Lit
any:[Lit]
xs)            = Lit
anyLit -> [Lit] -> [Lit]
forall a. a -> [a] -> [a]
: [Lit] -> [Lit]
joinL [Lit]
xs