{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE NoMonomorphismRestriction  #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE FlexibleInstances          #-}


---------------------------------------------------------------------------
-- | This module contains the code that uses the inferred types to generate
-- 1. HTMLized source with Inferred Types in mouseover annotations.
-- 2. Annotations files (e.g. for vim/emacs)
-- 3. JSON files for the web-demo etc.
---------------------------------------------------------------------------

module Language.Haskell.Liquid.UX.Annotate
  ( mkOutput
  , annotate
  , tokeniseWithLoc
  , annErrors
  ) where

import           Data.Hashable
import           Data.String
import           GHC                                          ( SrcSpan (..)
                                          , srcSpanStartCol
                                          , srcSpanEndCol
                                          , srcSpanStartLine
                                          , srcSpanEndLine)
import           GHC.Exts                                     (groupWith, sortWith)
import           Prelude                                      hiding (error)
import qualified SrcLoc
import           Text.PrettyPrint.HughesPJ                    hiding (first)
import           Text.Printf

import           Data.Char                                    (isSpace)
import           Data.Function                                (on)
import           Data.List                                    (sortBy)
import           Data.Maybe                                   (mapMaybe)

import           Data.Aeson
import           Control.Arrow                                hiding ((<+>))
-- import           Control.Applicative      ((<$>))
import           Control.Monad                                (when, forM_)

import           System.Exit                                  (ExitCode (..))
import           System.FilePath                              (takeFileName, dropFileName, (</>))
import           System.Directory                             (findExecutable)
import qualified System.Directory                             as Dir
import qualified Data.List                                    as L
import qualified Data.Vector                                  as V
import qualified Data.ByteString.Lazy                         as B
import qualified Data.Text                                    as T
import qualified Data.HashMap.Strict                          as M
import qualified Language.Haskell.Liquid.Misc                 as Misc 
import qualified Language.Haskell.Liquid.UX.ACSS              as ACSS
import           Language.Haskell.HsColour.Classify
import           Language.Fixpoint.Utils.Files
import           Language.Fixpoint.Misc
import           Language.Haskell.Liquid.GHC.Misc
import           Language.Fixpoint.Types                      hiding (panic, Error, Loc, Constant (..), Located (..))
import           Language.Haskell.Liquid.Misc
import           Language.Haskell.Liquid.Types.PrettyPrint
import           Language.Haskell.Liquid.Types.RefType

import           Language.Haskell.Liquid.UX.Tidy
import           Language.Haskell.Liquid.Types                hiding (Located(..), Def(..))
-- import           Language.Haskell.Liquid.Types.Specifications


-- | @output@ creates the pretty printed output
--------------------------------------------------------------------------------------------
mkOutput :: Config -> ErrorResult -> FixSolution -> AnnInfo (Annot SpecType) -> Output Doc
--------------------------------------------------------------------------------------------
mkOutput :: Config
-> ErrorResult
-> FixSolution
-> AnnInfo (Annot SpecType)
-> Output Doc
mkOutput Config
cfg ErrorResult
res FixSolution
sol AnnInfo (Annot SpecType)
anna
  = O :: forall a.
Maybe [String]
-> AnnInfo a -> AnnInfo a -> [SrcSpan] -> ErrorResult -> Output a
O { o_vars :: Maybe [String]
o_vars   = Maybe [String]
forall a. Maybe a
Nothing
      -- , o_errors = []
      , o_types :: AnnInfo Doc
o_types  = SpecType -> Doc
forall c tv r.
(TyConable c, PPrint tv, PPrint c, PPrint r, Reftable r,
 Reftable (RTProp c tv r), Reftable (RTProp c tv ()), Eq tv,
 Hashable tv) =>
RType c tv r -> Doc
toDoc (SpecType -> Doc) -> AnnInfo SpecType -> AnnInfo Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnInfo SpecType
annTy
      , o_templs :: AnnInfo Doc
o_templs = SpecType -> Doc
forall c tv r.
(TyConable c, PPrint tv, PPrint c, PPrint r, Reftable r,
 Reftable (RTProp c tv r), Reftable (RTProp c tv ()), Eq tv,
 Hashable tv) =>
RType c tv r -> Doc
toDoc (SpecType -> Doc) -> AnnInfo SpecType -> AnnInfo Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnInfo SpecType
annTmpl
      , o_bots :: [SrcSpan]
o_bots   = AnnInfo SpecType -> [SrcSpan]
forall r c tv. Reftable r => AnnInfo (RType c tv r) -> [SrcSpan]
mkBots    AnnInfo SpecType
annTy
      , o_result :: ErrorResult
o_result = ErrorResult
res
      }
  where
    annTmpl :: AnnInfo SpecType
annTmpl      = AnnInfo (Annot SpecType) -> AnnInfo SpecType
closeAnnots AnnInfo (Annot SpecType)
anna
    annTy :: AnnInfo SpecType
annTy        = Tidy -> SpecType -> SpecType
tidySpecType Tidy
Lossy (SpecType -> SpecType) -> AnnInfo SpecType -> AnnInfo SpecType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FixSolution -> AnnInfo SpecType -> AnnInfo SpecType
forall (f :: * -> *).
Functor f =>
FixSolution -> f SpecType -> f SpecType
applySolution FixSolution
sol AnnInfo SpecType
annTmpl
    toDoc :: RType c tv r -> Doc
toDoc        = Tidy -> RType c tv r -> Doc
forall c tv r. OkRT c tv r => Tidy -> RType c tv r -> Doc
rtypeDoc Tidy
tidy
    tidy :: Tidy
tidy         = if Config -> Bool
shortNames Config
cfg then Tidy
Lossy else Tidy
Full

-- | @annotate@ actually renders the output to files
-------------------------------------------------------------------
annotate :: Config -> [FilePath] -> Output Doc -> IO ACSS.AnnMap
-------------------------------------------------------------------
annotate :: Config -> [String] -> Output Doc -> IO AnnMap
annotate Config
cfg [String]
srcFs Output Doc
out
  = do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showWarns  (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [SrcSpan] -> (SrcSpan -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SrcSpan]
bots (String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"WARNING: Found false in %s\n" (String -> IO ()) -> (SrcSpan -> String) -> SrcSpan -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> String
forall a. Outputable a => a -> String
showPpr)
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doAnnotate (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Config -> AnnMap -> AnnMap -> AnnInfo Doc -> String -> IO ()
doGenerate Config
cfg AnnMap
tplAnnMap AnnMap
typAnnMap AnnInfo Doc
annTyp) [String]
srcFs
       AnnMap -> IO AnnMap
forall (m :: * -> *) a. Monad m => a -> m a
return AnnMap
typAnnMap
    where
       tplAnnMap :: AnnMap
tplAnnMap  = Config -> ErrorResult -> AnnInfo Doc -> AnnMap
mkAnnMap Config
cfg ErrorResult
res AnnInfo Doc
annTpl
       typAnnMap :: AnnMap
typAnnMap  = Config -> ErrorResult -> AnnInfo Doc -> AnnMap
mkAnnMap Config
cfg ErrorResult
res AnnInfo Doc
annTyp
       annTpl :: AnnInfo Doc
annTpl     = Output Doc -> AnnInfo Doc
forall a. Output a -> AnnInfo a
o_templs Output Doc
out
       annTyp :: AnnInfo Doc
annTyp     = Output Doc -> AnnInfo Doc
forall a. Output a -> AnnInfo a
o_types  Output Doc
out
       res :: ErrorResult
res        = Output Doc -> ErrorResult
forall a. Output a -> ErrorResult
o_result Output Doc
out
       bots :: [SrcSpan]
bots       = Output Doc -> [SrcSpan]
forall a. Output a -> [SrcSpan]
o_bots   Output Doc
out
       showWarns :: Bool
showWarns  = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Config -> Bool
nowarnings    Config
cfg
       doAnnotate :: Bool
doAnnotate = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Config -> Bool
noannotations Config
cfg

doGenerate :: Config -> ACSS.AnnMap -> ACSS.AnnMap -> AnnInfo Doc -> FilePath -> IO ()
doGenerate :: Config -> AnnMap -> AnnMap -> AnnInfo Doc -> String -> IO ()
doGenerate Config
cfg AnnMap
tplAnnMap AnnMap
typAnnMap AnnInfo Doc
annTyp String
srcF
  = do String -> String -> AnnMap -> IO ()
generateHtml String
srcF String
tpHtmlF AnnMap
tplAnnMap
       String -> String -> AnnMap -> IO ()
generateHtml String
srcF String
tyHtmlF AnnMap
typAnnMap
       String -> String -> IO ()
writeFile         String
vimF  (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> AnnInfo Doc -> String
vimAnnot Config
cfg AnnInfo Doc
annTyp
       String -> ByteString -> IO ()
B.writeFile       String
jsonF (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ AnnMap -> ByteString
forall a. ToJSON a => a -> ByteString
encode AnnMap
typAnnMap
    where
       tyHtmlF :: String
tyHtmlF    = Ext -> String -> String
extFileName Ext
Html                   String
srcF
       tpHtmlF :: String
tpHtmlF    = Ext -> String -> String
extFileName Ext
Html (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Ext -> String -> String
extFileName Ext
Cst String
srcF
       _annF :: String
_annF      = Ext -> String -> String
extFileName Ext
Annot String
srcF
       jsonF :: String
jsonF      = Ext -> String -> String
extFileName Ext
Json  String
srcF
       vimF :: String
vimF       = Ext -> String -> String
extFileName Ext
Vim   String
srcF

mkBots :: Reftable r => AnnInfo (RType c tv r) -> [GHC.SrcSpan]
mkBots :: AnnInfo (RType c tv r) -> [SrcSpan]
mkBots (AI HashMap SrcSpan [(Maybe Text, RType c tv r)]
m) = [ SrcSpan
src | (SrcSpan
src, (Just Text
_, RType c tv r
t) : [(Maybe Text, RType c tv r)]
_) <- ((SrcSpan, [(Maybe Text, RType c tv r)])
 -> (SrcSpan, [(Maybe Text, RType c tv r)]) -> Ordering)
-> [(SrcSpan, [(Maybe Text, RType c tv r)])]
-> [(SrcSpan, [(Maybe Text, RType c tv r)])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SrcSpan -> SrcSpan -> Ordering)
-> ((SrcSpan, [(Maybe Text, RType c tv r)]) -> SrcSpan)
-> (SrcSpan, [(Maybe Text, RType c tv r)])
-> (SrcSpan, [(Maybe Text, RType c tv r)])
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (SrcSpan, [(Maybe Text, RType c tv r)]) -> SrcSpan
forall a b. (a, b) -> a
fst) ([(SrcSpan, [(Maybe Text, RType c tv r)])]
 -> [(SrcSpan, [(Maybe Text, RType c tv r)])])
-> [(SrcSpan, [(Maybe Text, RType c tv r)])]
-> [(SrcSpan, [(Maybe Text, RType c tv r)])]
forall a b. (a -> b) -> a -> b
$ HashMap SrcSpan [(Maybe Text, RType c tv r)]
-> [(SrcSpan, [(Maybe Text, RType c tv r)])]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap SrcSpan [(Maybe Text, RType c tv r)]
m
                      , Reft -> Bool
forall a. Falseable a => a -> Bool
isFalse (RType c tv r -> Reft
forall r c tv. Reftable r => RType c tv r -> Reft
rTypeReft RType c tv r
t) ]

-- | Like 'copyFile' from 'System.Directory', but ensure that the parent /temporary/ directory 
-- (i.e. \".liquid\") exists on disk, creating it if necessary.
copyFileCreateParentDirIfMissing :: FilePath -> FilePath -> IO ()
copyFileCreateParentDirIfMissing :: String -> String -> IO ()
copyFileCreateParentDirIfMissing String
src String
tgt = do
  Bool -> String -> IO ()
Dir.createDirectoryIfMissing Bool
False (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
tempDirectory String
tgt
  String -> String -> IO ()
Dir.copyFile String
src String
tgt

writeFilesOrStrings :: FilePath -> [Either FilePath String] -> IO ()
writeFilesOrStrings :: String -> [Either String String] -> IO ()
writeFilesOrStrings String
tgtFile = (Either String String -> IO ()) -> [Either String String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Either String String -> IO ())
 -> [Either String String] -> IO ())
-> (Either String String -> IO ())
-> [Either String String]
-> IO ()
forall a b. (a -> b) -> a -> b
$ (String -> IO ())
-> (String -> IO ()) -> Either String String -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> String -> IO ()
`copyFileCreateParentDirIfMissing` String
tgtFile) (String
tgtFile String -> String -> IO ()
`appendFile`)

generateHtml :: FilePath -> FilePath -> ACSS.AnnMap -> IO ()
generateHtml :: String -> String -> AnnMap -> IO ()
generateHtml String
srcF String
htmlF AnnMap
annm
  = do String
src     <- String -> IO String
Misc.sayReadFile String
srcF
       let lhs :: Bool
lhs  = Ext -> String -> Bool
isExtFile Ext
LHs String
srcF
       let body :: String
body = {-# SCC "hsannot" #-} Bool -> CommentTransform -> Bool -> (String, AnnMap) -> String
ACSS.hsannot Bool
False ((String -> [(TokenType, String)]) -> CommentTransform
forall a. a -> Maybe a
Just String -> [(TokenType, String)]
tokAnnot) Bool
lhs (String
src, AnnMap
annm)
       String
cssFile <- IO String
getCssPath
       String -> String -> IO ()
copyFileCreateParentDirIfMissing String
cssFile (String -> String
dropFileName String
htmlF String -> String -> String
</> String -> String
takeFileName String
cssFile)
       Bool -> String -> String -> String -> String -> IO ()
renderHtml Bool
lhs String
htmlF String
srcF (String -> String
takeFileName String
cssFile) String
body

renderHtml :: Bool -> FilePath -> String -> String -> String -> IO ()
renderHtml :: Bool -> String -> String -> String -> String -> IO ()
renderHtml Bool
True  = String -> String -> String -> String -> IO ()
renderPandoc
renderHtml Bool
False = String -> String -> String -> String -> IO ()
renderDirect

-------------------------------------------------------------------------
-- | Pandoc HTML Rendering (for lhs + markdown source) ------------------
-------------------------------------------------------------------------
renderPandoc :: FilePath -> String -> String -> String -> IO ()
renderPandoc :: String -> String -> String -> String -> IO ()
renderPandoc String
htmlFile String
srcFile String
css String
body = do
  String -> String -> String -> String -> IO ()
renderFn <- (String -> String -> String -> String -> IO ())
-> (String -> String -> String -> String -> String -> IO ())
-> Maybe String
-> String
-> String
-> String
-> String
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String -> String -> String -> String -> IO ()
renderDirect String -> String -> String -> String -> String -> IO ()
renderPandoc' (Maybe String -> String -> String -> String -> String -> IO ())
-> IO (Maybe String)
-> IO (String -> String -> String -> String -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
findExecutable String
"pandoc"
  String -> String -> String -> String -> IO ()
renderFn String
htmlFile String
srcFile String
css String
body

renderPandoc' :: FilePath -> FilePath -> FilePath -> String -> String -> IO ()
renderPandoc' :: String -> String -> String -> String -> String -> IO ()
renderPandoc' String
pandocPath String
htmlFile String
srcFile String
css String
body = do
  ()
_  <- String -> String -> IO ()
writeFile String
mdFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
pandocPreProc String
body
  ExitCode
ec <- String -> String -> IO ExitCode
executeShellCommand String
"pandoc" String
cmd
  String -> [Either String String] -> IO ()
writeFilesOrStrings String
htmlFile [String -> Either String String
forall a b. b -> Either a b
Right (String -> String
cssHTML String
css)]
  String -> ExitCode -> IO ()
forall (m :: * -> *). Monad m => String -> ExitCode -> m ()
checkExitCode String
cmd ExitCode
ec
  where
    mdFile :: String
mdFile = Ext -> String -> String
extFileName Ext
Mkdn String
srcFile
    cmd :: String
cmd    = String -> String -> String -> String
pandocCmd String
pandocPath String
mdFile String
htmlFile

checkExitCode :: Monad m => String -> ExitCode -> m ()
checkExitCode :: String -> ExitCode -> m ()
checkExitCode String
_   (ExitCode
ExitSuccess)   = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkExitCode String
cmd (ExitFailure Int
n) = Maybe SrcSpan -> String -> m ()
forall a. Maybe SrcSpan -> String -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"cmd: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failure code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n

pandocCmd :: FilePath -> FilePath -> FilePath -> String
pandocCmd :: String -> String -> String -> String
pandocCmd -- pandocPath mdFile htmlFile
  = String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s -f markdown -t html %s > %s" -- pandocPath mdFile htmlFile

pandocPreProc :: String -> String
pandocPreProc :: String -> String
pandocPreProc  = Text -> String
T.unpack
               (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Text -> Text
forall t t. (PrintfArg t, PrintfArg t) => t -> t -> Text -> Text
strip String
beg String
code
               (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Text -> Text
forall t t. (PrintfArg t, PrintfArg t) => t -> t -> Text -> Text
strip String
end String
code
               (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Text -> Text
forall t t. (PrintfArg t, PrintfArg t) => t -> t -> Text -> Text
strip String
beg String
spec
               (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Text -> Text
forall t t. (PrintfArg t, PrintfArg t) => t -> t -> Text -> Text
strip String
end String
spec
               (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
  where
    beg, end, code, spec :: String
    beg :: String
beg        = String
"begin"
    end :: String
end        = String
"end"
    code :: String
code       = String
"code"
    spec :: String
spec       = String
"spec"
    strip :: t -> t -> Text -> Text
strip t
x t
y  = Text -> Text -> Text -> Text
T.replace (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> t -> t -> String
forall r. PrintfType r => String -> r
printf String
"\\%s{%s}" t
x t
y) Text
T.empty


-------------------------------------------------------------------------
-- | Direct HTML Rendering (for non-lhs/markdown source) ----------------
-------------------------------------------------------------------------

-- More or less taken from hscolour

renderDirect :: FilePath -> String -> String -> String -> IO ()
renderDirect :: String -> String -> String -> String -> IO ()
renderDirect String
htmlFile String
srcFile String
css String
body
  = String -> String -> IO ()
writeFile String
htmlFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$! (Bool -> String -> String -> String -> String
topAndTail Bool
full String
srcFile String
css (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$! String
body)
    where full :: Bool
full = Bool
True -- False  -- TODO: command-line-option

-- | @topAndTail True@ is used for standalone HTML; @topAndTail False@ for embedded HTML
topAndTail :: Bool -> String -> String -> String -> String
topAndTail :: Bool -> String -> String -> String -> String
topAndTail Bool
True  String
title String
css = (String -> String -> String
htmlHeader String
title String
css String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
forall a. IsString a => a
htmlClose)
topAndTail Bool
False String
_    String
_    = String -> String
forall a. a -> a
id

-- Use this for standalone HTML
htmlHeader :: String -> String -> String
htmlHeader :: String -> String -> String
htmlHeader String
title String
css = [String] -> String
unlines
  [ String
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"
  , String
"<html>"
  , String
"<head>"
  , String
"<title>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
title String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"</title>"
  , String
"</head>"
  , String -> String
cssHTML String
css
  , String
"<body>"
  , String
"<hr>"
  , String
"Put mouse over identifiers to see inferred types"
  ]

htmlClose :: IsString a => a
htmlClose :: a
htmlClose  = a
"\n</body>\n</html>"

cssHTML :: String -> String
cssHTML :: String -> String
cssHTML String
css = [String] -> String
unlines
  [ String
"<head>"
  , String
"<link type='text/css' rel='stylesheet' href='"String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
css String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' />"
  , String
"</head>"
  ]

------------------------------------------------------------------------------
-- | Building Annotation Maps ------------------------------------------------
------------------------------------------------------------------------------

-- | This function converts our annotation information into that which
--   is required by `Language.Haskell.Liquid.ACSS` to generate mouseover
--   annotations.

mkAnnMap :: Config -> ErrorResult -> AnnInfo Doc -> ACSS.AnnMap
mkAnnMap :: Config -> ErrorResult -> AnnInfo Doc -> AnnMap
mkAnnMap Config
cfg ErrorResult
res AnnInfo Doc
ann     = Ann :: HashMap Loc (String, String)
-> [(Loc, Loc, String)]
-> Status
-> [(RealSrcSpan, (String, String))]
-> AnnMap
ACSS.Ann 
                             { types :: HashMap Loc (String, String)
ACSS.types   = Config -> AnnInfo Doc -> HashMap Loc (String, String)
mkAnnMapTyp Config
cfg AnnInfo Doc
ann 
                             , errors :: [(Loc, Loc, String)]
ACSS.errors  = ErrorResult -> [(Loc, Loc, String)]
forall t.
PPrint (TError t) =>
FixResult (TError t) -> [(Loc, Loc, String)]
mkAnnMapErr ErrorResult
res 
                             , status :: Status
ACSS.status  = ErrorResult -> Status
forall t. FixResult t -> Status
mkStatus ErrorResult
res 
                             , sptypes :: [(RealSrcSpan, (String, String))]
ACSS.sptypes = Config -> AnnInfo Doc -> [(RealSrcSpan, (String, String))]
mkAnnMapBinders Config
cfg AnnInfo Doc
ann
                             }

mkStatus :: FixResult t -> ACSS.Status
mkStatus :: FixResult t -> Status
mkStatus (Safe Stats
_)        = Status
ACSS.Safe
mkStatus (Unsafe Stats
_ [t]
_)    = Status
ACSS.Unsafe
mkStatus (Crash [t]
_ String
_)     = Status
ACSS.Error



mkAnnMapErr :: PPrint (TError t)
            => FixResult (TError t) -> [(Loc, Loc, String)]
mkAnnMapErr :: FixResult (TError t) -> [(Loc, Loc, String)]
mkAnnMapErr (Unsafe Stats
_ [TError t]
ls) = (TError t -> Maybe (Loc, Loc, String))
-> [TError t] -> [(Loc, Loc, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TError t -> Maybe (Loc, Loc, String)
forall t. PPrint (TError t) => TError t -> Maybe (Loc, Loc, String)
cinfoErr [TError t]
ls
mkAnnMapErr (Crash [TError t]
ls String
_)  = (TError t -> Maybe (Loc, Loc, String))
-> [TError t] -> [(Loc, Loc, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TError t -> Maybe (Loc, Loc, String)
forall t. PPrint (TError t) => TError t -> Maybe (Loc, Loc, String)
cinfoErr [TError t]
ls
mkAnnMapErr FixResult (TError t)
_             = []

cinfoErr :: PPrint (TError t) => TError t -> Maybe (Loc, Loc, String)
cinfoErr :: TError t -> Maybe (Loc, Loc, String)
cinfoErr TError t
e = case TError t -> SrcSpan
forall t. TError t -> SrcSpan
pos TError t
e of
               RealSrcSpan RealSrcSpan
l -> (Loc, Loc, String) -> Maybe (Loc, Loc, String)
forall a. a -> Maybe a
Just (RealSrcSpan -> Loc
srcSpanStartLoc RealSrcSpan
l, RealSrcSpan -> Loc
srcSpanEndLoc RealSrcSpan
l, TError t -> String
forall a. PPrint a => a -> String
showpp TError t
e)
               SrcSpan
_             -> Maybe (Loc, Loc, String)
forall a. Maybe a
Nothing


-- mkAnnMapTyp :: (RefTypable a c tv r, RefTypable a c tv (), PPrint tv, PPrint a) =>Config-> AnnInfo (RType a c tv r) -> M.HashMap Loc (String, String)
mkAnnMapTyp :: Config -> AnnInfo Doc -> M.HashMap Loc (String, String)
mkAnnMapTyp :: Config -> AnnInfo Doc -> HashMap Loc (String, String)
mkAnnMapTyp Config
cfg AnnInfo Doc
z = [(Loc, (String, String))] -> HashMap Loc (String, String)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Loc, (String, String))] -> HashMap Loc (String, String))
-> [(Loc, (String, String))] -> HashMap Loc (String, String)
forall a b. (a -> b) -> a -> b
$ ((RealSrcSpan, (String, String)) -> (Loc, (String, String)))
-> [(RealSrcSpan, (String, String))] -> [(Loc, (String, String))]
forall a b. (a -> b) -> [a] -> [b]
map ((RealSrcSpan -> Loc)
-> (RealSrcSpan, (String, String)) -> (Loc, (String, String))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first RealSrcSpan -> Loc
srcSpanStartLoc) ([(RealSrcSpan, (String, String))] -> [(Loc, (String, String))])
-> [(RealSrcSpan, (String, String))] -> [(Loc, (String, String))]
forall a b. (a -> b) -> a -> b
$ Config -> AnnInfo Doc -> [(RealSrcSpan, (String, String))]
mkAnnMapBinders Config
cfg AnnInfo Doc
z

mkAnnMapBinders :: Config -> AnnInfo Doc -> [(SrcLoc.RealSrcSpan, (String, String))]
mkAnnMapBinders :: Config -> AnnInfo Doc -> [(RealSrcSpan, (String, String))]
mkAnnMapBinders Config
cfg (AI HashMap SrcSpan [(Maybe Text, Doc)]
m)
  = ([(RealSrcSpan, (Maybe Text, Doc))]
 -> (RealSrcSpan, (String, String)))
-> [[(RealSrcSpan, (Maybe Text, Doc))]]
-> [(RealSrcSpan, (String, String))]
forall a b. (a -> b) -> [a] -> [b]
map (((Maybe Text, Doc) -> (String, String))
-> (RealSrcSpan, (Maybe Text, Doc))
-> (RealSrcSpan, (String, String))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Maybe Text, Doc) -> (String, String)
forall a. Symbolic a => (Maybe a, Doc) -> (String, String)
bindStr ((RealSrcSpan, (Maybe Text, Doc))
 -> (RealSrcSpan, (String, String)))
-> ([(RealSrcSpan, (Maybe Text, Doc))]
    -> (RealSrcSpan, (Maybe Text, Doc)))
-> [(RealSrcSpan, (Maybe Text, Doc))]
-> (RealSrcSpan, (String, String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RealSrcSpan, (Maybe Text, Doc))]
-> (RealSrcSpan, (Maybe Text, Doc))
forall a. [a] -> a
head ([(RealSrcSpan, (Maybe Text, Doc))]
 -> (RealSrcSpan, (Maybe Text, Doc)))
-> ([(RealSrcSpan, (Maybe Text, Doc))]
    -> [(RealSrcSpan, (Maybe Text, Doc))])
-> [(RealSrcSpan, (Maybe Text, Doc))]
-> (RealSrcSpan, (Maybe Text, Doc))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RealSrcSpan, (Maybe Text, Doc)) -> Int)
-> [(RealSrcSpan, (Maybe Text, Doc))]
-> [(RealSrcSpan, (Maybe Text, Doc))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (RealSrcSpan -> Int
srcSpanEndCol (RealSrcSpan -> Int)
-> ((RealSrcSpan, (Maybe Text, Doc)) -> RealSrcSpan)
-> (RealSrcSpan, (Maybe Text, Doc))
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealSrcSpan, (Maybe Text, Doc)) -> RealSrcSpan
forall a b. (a, b) -> a
fst))
  ([[(RealSrcSpan, (Maybe Text, Doc))]]
 -> [(RealSrcSpan, (String, String))])
-> [[(RealSrcSpan, (Maybe Text, Doc))]]
-> [(RealSrcSpan, (String, String))]
forall a b. (a -> b) -> a -> b
$ ((RealSrcSpan, (Maybe Text, Doc)) -> (Int, Int))
-> [(RealSrcSpan, (Maybe Text, Doc))]
-> [[(RealSrcSpan, (Maybe Text, Doc))]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith (RealSrcSpan -> (Int, Int)
lineCol (RealSrcSpan -> (Int, Int))
-> ((RealSrcSpan, (Maybe Text, Doc)) -> RealSrcSpan)
-> (RealSrcSpan, (Maybe Text, Doc))
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealSrcSpan, (Maybe Text, Doc)) -> RealSrcSpan
forall a b. (a, b) -> a
fst) [(RealSrcSpan, (Maybe Text, Doc))]
locBinds
  where
    locBinds :: [(RealSrcSpan, (Maybe Text, Doc))]
locBinds       = [ (RealSrcSpan
l, (Maybe Text, Doc)
x) | (RealSrcSpan RealSrcSpan
l, (Maybe Text, Doc)
x:[(Maybe Text, Doc)]
_) <- HashMap SrcSpan [(Maybe Text, Doc)]
-> [(SrcSpan, [(Maybe Text, Doc)])]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap SrcSpan [(Maybe Text, Doc)]
m, RealSrcSpan -> Bool
oneLine RealSrcSpan
l]
    bindStr :: (Maybe a, Doc) -> (String, String)
bindStr (Maybe a
x, Doc
v) = (String -> (a -> String) -> Maybe a -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"_" (Symbol -> String
symbolString (Symbol -> String) -> (a -> Symbol) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
shorten (Symbol -> Symbol) -> (a -> Symbol) -> a -> Symbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Symbol
forall a. Symbolic a => a -> Symbol
symbol) Maybe a
x, Doc -> String
render Doc
v)
    shorten :: Symbol -> Symbol
shorten        = if Config -> Bool
shortNames Config
cfg then Symbol -> Symbol
dropModuleNames else Symbol -> Symbol
forall a. a -> a
id

closeAnnots :: AnnInfo (Annot SpecType) -> AnnInfo SpecType
closeAnnots :: AnnInfo (Annot SpecType) -> AnnInfo SpecType
closeAnnots = AnnInfo (Annot SpecType) -> AnnInfo SpecType
forall b. AnnInfo (Annot b) -> AnnInfo b
closeA (AnnInfo (Annot SpecType) -> AnnInfo SpecType)
-> (AnnInfo (Annot SpecType) -> AnnInfo (Annot SpecType))
-> AnnInfo (Annot SpecType)
-> AnnInfo SpecType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnInfo (Annot SpecType) -> AnnInfo (Annot SpecType)
forall t. AnnInfo (Annot t) -> AnnInfo (Annot t)
filterA (AnnInfo (Annot SpecType) -> AnnInfo (Annot SpecType))
-> (AnnInfo (Annot SpecType) -> AnnInfo (Annot SpecType))
-> AnnInfo (Annot SpecType)
-> AnnInfo (Annot SpecType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnInfo (Annot SpecType) -> AnnInfo (Annot SpecType)
forall t. AnnInfo (Annot t) -> AnnInfo (Annot t)
collapseA

closeA :: AnnInfo (Annot b) -> AnnInfo b
closeA :: AnnInfo (Annot b) -> AnnInfo b
closeA a :: AnnInfo (Annot b)
a@(AI HashMap SrcSpan [(Maybe Text, Annot b)]
m)   = Annot b -> b
cf (Annot b -> b) -> AnnInfo (Annot b) -> AnnInfo b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnInfo (Annot b)
a
  where
    cf :: Annot b -> b
cf (AnnLoc SrcSpan
l)  = case HashMap SrcSpan [(Maybe Text, Annot b)]
m HashMap SrcSpan [(Maybe Text, Annot b)]
-> SrcSpan -> [(Maybe Text, Annot b)]
forall k v.
(?callStack::CallStack, Eq k, Show k, Hashable k) =>
HashMap k v -> k -> v
`mlookup` SrcSpan
l of
                      [(Maybe Text
_, AnnUse b
t)] -> b
t
                      [(Maybe Text
_, AnnDef b
t)] -> b
t
                      [(Maybe Text
_, AnnRDf b
t)] -> b
t
                      [(Maybe Text, Annot b)]
_               -> Maybe SrcSpan -> String -> b
forall a. Maybe SrcSpan -> String -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ String
"malformed AnnInfo: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcSpan -> String
forall a. Outputable a => a -> String
showPpr SrcSpan
l
    cf (AnnUse b
t) = b
t
    cf (AnnDef b
t) = b
t
    cf (AnnRDf b
t) = b
t

filterA :: AnnInfo (Annot t) -> AnnInfo (Annot t)
filterA :: AnnInfo (Annot t) -> AnnInfo (Annot t)
filterA (AI HashMap SrcSpan [(Maybe Text, Annot t)]
m) = HashMap SrcSpan [(Maybe Text, Annot t)] -> AnnInfo (Annot t)
forall a. HashMap SrcSpan [(Maybe Text, a)] -> AnnInfo a
AI (([(Maybe Text, Annot t)] -> Bool)
-> HashMap SrcSpan [(Maybe Text, Annot t)]
-> HashMap SrcSpan [(Maybe Text, Annot t)]
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
M.filter [(Maybe Text, Annot t)] -> Bool
forall a t. [(a, Annot t)] -> Bool
ff HashMap SrcSpan [(Maybe Text, Annot t)]
m)
  where
    ff :: [(a, Annot t)] -> Bool
ff [(a
_, AnnLoc SrcSpan
l)] = SrcSpan
l SrcSpan -> HashMap SrcSpan [(Maybe Text, Annot t)] -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
`M.member` HashMap SrcSpan [(Maybe Text, Annot t)]
m
    ff [(a, Annot t)]
_               = Bool
True

collapseA :: AnnInfo (Annot t) -> AnnInfo (Annot t)
collapseA :: AnnInfo (Annot t) -> AnnInfo (Annot t)
collapseA (AI HashMap SrcSpan [(Maybe Text, Annot t)]
m) = HashMap SrcSpan [(Maybe Text, Annot t)] -> AnnInfo (Annot t)
forall a. HashMap SrcSpan [(Maybe Text, a)] -> AnnInfo a
AI (([(Maybe Text, Annot t)] -> [(Maybe Text, Annot t)])
-> HashMap SrcSpan [(Maybe Text, Annot t)]
-> HashMap SrcSpan [(Maybe Text, Annot t)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Maybe Text, Annot t)] -> [(Maybe Text, Annot t)]
forall t t1. [(t, Annot t1)] -> [(t, Annot t1)]
pickOneA HashMap SrcSpan [(Maybe Text, Annot t)]
m)

pickOneA :: [(t, Annot t1)] -> [(t, Annot t1)]
pickOneA :: [(t, Annot t1)] -> [(t, Annot t1)]
pickOneA [(t, Annot t1)]
xas = case ([(t, Annot t1)]
rs, [(t, Annot t1)]
ds, [(t, Annot t1)]
ls, [(t, Annot t1)]
us) of
                 ((t, Annot t1)
x:[(t, Annot t1)]
_, [(t, Annot t1)]
_, [(t, Annot t1)]
_, [(t, Annot t1)]
_) -> [(t, Annot t1)
x]
                 ([(t, Annot t1)]
_, (t, Annot t1)
x:[(t, Annot t1)]
_, [(t, Annot t1)]
_, [(t, Annot t1)]
_) -> [(t, Annot t1)
x]
                 ([(t, Annot t1)]
_, [(t, Annot t1)]
_, (t, Annot t1)
x:[(t, Annot t1)]
_, [(t, Annot t1)]
_) -> [(t, Annot t1)
x]
                 ([(t, Annot t1)]
_, [(t, Annot t1)]
_, [(t, Annot t1)]
_, (t, Annot t1)
x:[(t, Annot t1)]
_) -> [(t, Annot t1)
x]
                 ([(t, Annot t1)]
_, [(t, Annot t1)]
_, [(t, Annot t1)]
_, [(t, Annot t1)]
_  ) -> [ ]
  where
    rs :: [(t, Annot t1)]
rs = [(t, Annot t1)
x | x :: (t, Annot t1)
x@(t
_, AnnRDf t1
_) <- [(t, Annot t1)]
xas]
    ds :: [(t, Annot t1)]
ds = [(t, Annot t1)
x | x :: (t, Annot t1)
x@(t
_, AnnDef t1
_) <- [(t, Annot t1)]
xas]
    ls :: [(t, Annot t1)]
ls = [(t, Annot t1)
x | x :: (t, Annot t1)
x@(t
_, AnnLoc SrcSpan
_) <- [(t, Annot t1)]
xas]
    us :: [(t, Annot t1)]
us = [(t, Annot t1)
x | x :: (t, Annot t1)
x@(t
_, AnnUse t1
_) <- [(t, Annot t1)]
xas]

------------------------------------------------------------------------------
-- | Tokenizing Refinement Type Annotations in @-blocks ----------------------
------------------------------------------------------------------------------

-- | The token used for refinement symbols inside the highlighted types in @-blocks.
refToken :: TokenType
refToken :: TokenType
refToken = TokenType
Keyword

-- | The top-level function for tokenizing @-block annotations. Used to
-- tokenize comments by ACSS.
tokAnnot :: String -> [(TokenType, String)]
tokAnnot :: String -> [(TokenType, String)]
tokAnnot String
s
  = case String -> Maybe (String, String, String)
trimLiquidAnnot String
s of
      Just (String
l, String
body, String
r) -> [(TokenType
refToken, String
l)] [(TokenType, String)]
-> [(TokenType, String)] -> [(TokenType, String)]
forall a. [a] -> [a] -> [a]
++ String -> [(TokenType, String)]
tokBody String
body [(TokenType, String)]
-> [(TokenType, String)] -> [(TokenType, String)]
forall a. [a] -> [a] -> [a]
++ [(TokenType
refToken, String
r)]
      Maybe (String, String, String)
Nothing           -> [(TokenType
Comment, String
s)]

trimLiquidAnnot :: String -> Maybe (String, String, String)
trimLiquidAnnot :: String -> Maybe (String, String, String)
trimLiquidAnnot (Char
'{':Char
'-':Char
'@':String
ss)
  | Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ss Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) String
ss String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"@-}"
  = (String, String, String) -> Maybe (String, String, String)
forall a. a -> Maybe a
Just (String
liquidBegin, Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ss Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) String
ss, String
liquidEnd)
trimLiquidAnnot String
_
  = Maybe (String, String, String)
forall a. Maybe a
Nothing

tokBody :: String -> [(TokenType, String)]
tokBody :: String -> [(TokenType, String)]
tokBody String
s
  | String -> Bool
isData String
s  = String -> [(TokenType, String)]
tokenise String
s
  | String -> Bool
isType String
s  = String -> [(TokenType, String)]
tokenise String
s
  | String -> Bool
isIncl String
s  = String -> [(TokenType, String)]
tokenise String
s
  | String -> Bool
isMeas String
s  = String -> [(TokenType, String)]
tokenise String
s
  | Bool
otherwise = String -> [(TokenType, String)]
tokeniseSpec String
s

isMeas :: String -> Bool
isMeas :: String -> Bool
isMeas = String -> String -> Bool
spacePrefix String
"measure"

isData :: String -> Bool
isData :: String -> Bool
isData = String -> String -> Bool
spacePrefix String
"data"

isType :: String -> Bool
isType :: String -> Bool
isType = String -> String -> Bool
spacePrefix String
"type"

isIncl :: String -> Bool
isIncl :: String -> Bool
isIncl = String -> String -> Bool
spacePrefix String
"include"

{-@ spacePrefix :: String -> s:String -> Bool / [len s] @-}
spacePrefix :: String -> String -> Bool
spacePrefix :: String -> String -> Bool
spacePrefix String
str s :: String
s@(Char
c:String
cs)
  | Char -> Bool
isSpace Char
c   = String -> String -> Bool
spacePrefix String
str String
cs
  | Bool
otherwise   = Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
str
spacePrefix String
_ String
_ = Bool
False


tokeniseSpec :: String -> [(TokenType, String)]
tokeniseSpec :: String -> [(TokenType, String)]
tokeniseSpec       = [String] -> [(TokenType, String)]
tokAlt ([String] -> [(TokenType, String)])
-> (String -> [String]) -> String -> [(TokenType, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
chopAltDBG
  where
    tokAlt :: [String] -> [(TokenType, String)]
tokAlt (String
s:[String]
ss)  = String -> [(TokenType, String)]
tokenise String
s [(TokenType, String)]
-> [(TokenType, String)] -> [(TokenType, String)]
forall a. [a] -> [a] -> [a]
++ [String] -> [(TokenType, String)]
tokAlt' [String]
ss
    tokAlt [String]
_       = []
    tokAlt' :: [String] -> [(TokenType, String)]
tokAlt' (String
s:[String]
ss) = (TokenType
refToken, String
s) (TokenType, String)
-> [(TokenType, String)] -> [(TokenType, String)]
forall a. a -> [a] -> [a]
: [String] -> [(TokenType, String)]
tokAlt [String]
ss
    tokAlt' [String]
_      = []

chopAltDBG :: String -> [String]
chopAltDBG :: String -> [String]
chopAltDBG String
y = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"")
             ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(String, String)] -> String -> [String]
chopAlts [(String
"{", String
":"), (String
"|", String
"}")])
             ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> String -> [String]
chopAlts [(String
"<{", String
"}>"), (String
"{", String
"}")] String
y


------------------------------------------------------------------------
-- | JSON: Annotation Data Types ---------------------------------------
------------------------------------------------------------------------

data Assoc k a    = Asc (M.HashMap k a)
type AnnTypes     = Assoc Int (Assoc Int Annot1)
newtype AnnErrors = AnnErrors [(Loc, Loc, String)]
data Annot1       = A1  { Annot1 -> String
ident :: String
                        , Annot1 -> String
ann   :: String
                        , Annot1 -> Int
row   :: Int
                        , Annot1 -> Int
col   :: Int
                        }

------------------------------------------------------------------------
-- | Creating Vim Annotations ------------------------------------------
------------------------------------------------------------------------
vimAnnot     :: Config -> AnnInfo Doc -> String
vimAnnot :: Config -> AnnInfo Doc -> String
vimAnnot Config
cfg = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"\n" ([String] -> String)
-> (AnnInfo Doc -> [String]) -> AnnInfo Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RealSrcSpan, (String, String)) -> String)
-> [(RealSrcSpan, (String, String))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (RealSrcSpan, (String, String)) -> String
forall a t.
(Show a, PrintfType t) =>
(RealSrcSpan, (String, a)) -> t
vimBind ([(RealSrcSpan, (String, String))] -> [String])
-> (AnnInfo Doc -> [(RealSrcSpan, (String, String))])
-> AnnInfo Doc
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> AnnInfo Doc -> [(RealSrcSpan, (String, String))]
mkAnnMapBinders Config
cfg

vimBind :: (Show a, PrintfType t) => (SrcLoc.RealSrcSpan, (String, a)) -> t
vimBind :: (RealSrcSpan, (String, a)) -> t
vimBind (RealSrcSpan
sp, (String
v, a
ann)) = String -> Int -> Int -> Int -> Int -> String -> t
forall r. PrintfType r => String -> r
printf String
"%d:%d-%d:%d::%s" Int
l1 Int
c1 Int
l2 Int
c2 (String
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
ann)
  where
    l1 :: Int
l1  = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
sp
    c1 :: Int
c1  = RealSrcSpan -> Int
srcSpanStartCol  RealSrcSpan
sp
    l2 :: Int
l2  = RealSrcSpan -> Int
srcSpanEndLine   RealSrcSpan
sp
    c2 :: Int
c2  = RealSrcSpan -> Int
srcSpanEndCol    RealSrcSpan
sp

------------------------------------------------------------------------
-- | JSON Instances ----------------------------------------------------
------------------------------------------------------------------------

instance ToJSON ACSS.Status where
  toJSON :: Status -> Value
toJSON Status
ACSS.Safe   = Value
"safe"
  toJSON Status
ACSS.Unsafe = Value
"unsafe"
  toJSON Status
ACSS.Error  = Value
"error"
  toJSON Status
ACSS.Crash  = Value
"crash"

instance ToJSON Annot1 where
  toJSON :: Annot1 -> Value
toJSON (A1 String
i String
a Int
r Int
c) = [Pair] -> Value
object [ Text
"ident" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
i
                               , Text
"ann"   Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
a
                               , Text
"row"   Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
r
                               , Text
"col"   Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
c
                               ]

instance ToJSON Loc where
  toJSON :: Loc -> Value
toJSON (L (Int
l, Int
c)) = [Pair] -> Value
object [ Text
"line"     Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
l
                             , Text
"column"   Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
c ]

instance ToJSON AnnErrors where
  toJSON :: AnnErrors -> Value
toJSON (AnnErrors [(Loc, Loc, String)]
errs) = Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
V.fromList ((Loc, Loc, String) -> Value
forall a a. (ToJSON a, ToJSON a) => (a, a, String) -> Value
toJ ((Loc, Loc, String) -> Value) -> [(Loc, Loc, String)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Loc, Loc, String)]
errs)
    where
      toJ :: (a, a, String) -> Value
toJ (a
l,a
l',String
s)        = [Pair] -> Value
object [ Text
"start"   Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
forall a. ToJSON a => a -> Value
toJSON a
l
                                   , Text
"stop"    Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
forall a. ToJSON a => a -> Value
toJSON a
l'
                                   , Text
"message" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> String
dropErrorLoc String
s)
                                   ]




dropErrorLoc :: String -> String
dropErrorLoc :: String -> String
dropErrorLoc String
msg
  | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
msg' = String
msg
  | Bool
otherwise = String -> String
forall a. [a] -> [a]
tail String
msg'
  where
    (String
_, String
msg') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
' ' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
msg

instance (Show k, ToJSON a) => ToJSON (Assoc k a) where
  toJSON :: Assoc k a -> Value
toJSON (Asc HashMap k a
kas) = [Pair] -> Value
object [ k -> Text
forall a. Show a => a -> Text
tshow k
k Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a | (k
k, a
a) <- HashMap k a -> [(k, a)]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap k a
kas ]
    where
      tshow :: a -> Text
tshow        = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

instance ToJSON ACSS.AnnMap where
  toJSON :: AnnMap -> Value
toJSON AnnMap
a = [Pair] -> Value
object [ Text
"types"   Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AnnTypes -> Value
forall a. ToJSON a => a -> Value
toJSON (AnnMap -> AnnTypes
annTypes     AnnMap
a)
                    , Text
"errors"  Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AnnErrors -> Value
forall a. ToJSON a => a -> Value
toJSON (AnnMap -> AnnErrors
annErrors    AnnMap
a)
                    , Text
"status"  Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Status -> Value
forall a. ToJSON a => a -> Value
toJSON (AnnMap -> Status
ACSS.status  AnnMap
a)
                    , Text
"sptypes" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((RealSrcSpan, (String, String)) -> Value
forall a a. (ToJSON a, ToJSON a) => (RealSrcSpan, (a, a)) -> Value
toJ ((RealSrcSpan, (String, String)) -> Value)
-> [(RealSrcSpan, (String, String))] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnMap -> [(RealSrcSpan, (String, String))]
ACSS.sptypes AnnMap
a) 
                    ]
    where 
      toJ :: (RealSrcSpan, (a, a)) -> Value
toJ (RealSrcSpan
sp, (a
x,a
t)) = [Pair] -> Value
object [ Text
"start" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Loc -> Value
forall a. ToJSON a => a -> Value
toJSON (RealSrcSpan -> Loc
srcSpanStartLoc RealSrcSpan
sp) 
                               , Text
"stop"  Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Loc -> Value
forall a. ToJSON a => a -> Value
toJSON (RealSrcSpan -> Loc
srcSpanEndLoc   RealSrcSpan
sp) 
                               , Text
"ident" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x 
                               , Text
"ann"  Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
forall a. ToJSON a => a -> Value
toJSON a
t 
                               ] 
                      
annErrors :: ACSS.AnnMap -> AnnErrors
annErrors :: AnnMap -> AnnErrors
annErrors = [(Loc, Loc, String)] -> AnnErrors
AnnErrors ([(Loc, Loc, String)] -> AnnErrors)
-> (AnnMap -> [(Loc, Loc, String)]) -> AnnMap -> AnnErrors
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnMap -> [(Loc, Loc, String)]
ACSS.errors

annTypes         :: ACSS.AnnMap -> AnnTypes
annTypes :: AnnMap -> AnnTypes
annTypes AnnMap
a       = [(Int, Int, Annot1)] -> AnnTypes
forall (t :: * -> *) k k1 a.
(Foldable t, Eq k, Eq k1, Hashable k, Hashable k1) =>
t (k, k1, a) -> Assoc k (Assoc k1 a)
grp [(Int
l, Int
c, Int -> Int -> String -> String -> Annot1
ann1 Int
l Int
c String
x String
s) | (Int
l, Int
c, String
x, String
s) <- [(Int, Int, String, String)]
binders]
  where
    ann1 :: Int -> Int -> String -> String -> Annot1
ann1 Int
l Int
c String
x String
s = String -> String -> Int -> Int -> Annot1
A1 String
x String
s Int
l Int
c
    grp :: t (k, k1, a) -> Assoc k (Assoc k1 a)
grp          = (Assoc k (Assoc k1 a) -> (k, k1, a) -> Assoc k (Assoc k1 a))
-> Assoc k (Assoc k1 a) -> t (k, k1, a) -> Assoc k (Assoc k1 a)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (\Assoc k (Assoc k1 a)
m (k
r,k1
c,a
x) -> k -> k1 -> a -> Assoc k (Assoc k1 a) -> Assoc k (Assoc k1 a)
forall k k1 a.
(Eq k, Eq k1, Hashable k, Hashable k1) =>
k -> k1 -> a -> Assoc k (Assoc k1 a) -> Assoc k (Assoc k1 a)
ins k
r k1
c a
x Assoc k (Assoc k1 a)
m) (HashMap k (Assoc k1 a) -> Assoc k (Assoc k1 a)
forall k a. HashMap k a -> Assoc k a
Asc HashMap k (Assoc k1 a)
forall k v. HashMap k v
M.empty)
    binders :: [(Int, Int, String, String)]
binders      = [(Int
l, Int
c, String
x, String
s) | (L (Int
l, Int
c), (String
x, String
s)) <- HashMap Loc (String, String) -> [(Loc, (String, String))]
forall k v. HashMap k v -> [(k, v)]
M.toList (HashMap Loc (String, String) -> [(Loc, (String, String))])
-> HashMap Loc (String, String) -> [(Loc, (String, String))]
forall a b. (a -> b) -> a -> b
$ AnnMap -> HashMap Loc (String, String)
ACSS.types AnnMap
a]

ins :: (Eq k, Eq k1, Hashable k, Hashable k1)
    => k -> k1 -> a -> Assoc k (Assoc k1 a) -> Assoc k (Assoc k1 a)
ins :: k -> k1 -> a -> Assoc k (Assoc k1 a) -> Assoc k (Assoc k1 a)
ins k
r k1
c a
x (Asc HashMap k (Assoc k1 a)
m)  = HashMap k (Assoc k1 a) -> Assoc k (Assoc k1 a)
forall k a. HashMap k a -> Assoc k a
Asc (k -> Assoc k1 a -> HashMap k (Assoc k1 a) -> HashMap k (Assoc k1 a)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert k
r (HashMap k1 a -> Assoc k1 a
forall k a. HashMap k a -> Assoc k a
Asc (k1 -> a -> HashMap k1 a -> HashMap k1 a
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert k1
c a
x HashMap k1 a
rm)) HashMap k (Assoc k1 a)
m)
  where
    Asc HashMap k1 a
rm         = Assoc k1 a -> k -> HashMap k (Assoc k1 a) -> Assoc k1 a
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
M.lookupDefault (HashMap k1 a -> Assoc k1 a
forall k a. HashMap k a -> Assoc k a
Asc HashMap k1 a
forall k v. HashMap k v
M.empty) k
r HashMap k (Assoc k1 a)
m

tokeniseWithLoc :: String -> [(TokenType, String, Loc)]
tokeniseWithLoc :: String -> [(TokenType, String, Loc)]
tokeniseWithLoc = CommentTransform -> String -> [(TokenType, String, Loc)]
ACSS.tokeniseWithLoc ((String -> [(TokenType, String)]) -> CommentTransform
forall a. a -> Maybe a
Just String -> [(TokenType, String)]
tokAnnot)

--------------------------------------------------------------------------------
-- | LH Related Stuff ----------------------------------------------------------
--------------------------------------------------------------------------------

{-@ LIQUID "--diffcheck" @-}

{-@ type ListNE a    = {v:[a] | 0 < len v}  @-}
{-@ type ListN  a N  = {v:[a] | len v == N} @-}
{-@ type ListXs a Xs = ListN a {len Xs}     @-}

{-@ assume GHC.Exts.sortWith :: Ord b => (a -> b) -> xs:[a] -> ListXs a xs @-}
{-@ assume GHC.Exts.groupWith :: Ord b => (a -> b) -> [a] -> [ListNE a] @-}

--------------------------------------------------------------------------------
-- | A Little Unit Test --------------------------------------------------------
--------------------------------------------------------------------------------

_anns :: AnnTypes
_anns :: AnnTypes
_anns = [(Int, Assoc Int Annot1)] -> AnnTypes
forall k a. (Eq k, Hashable k) => [(k, a)] -> Assoc k a
i [(Int
5,   [(Int, Annot1)] -> Assoc Int Annot1
forall k a. (Eq k, Hashable k) => [(k, a)] -> Assoc k a
i [( Int
14, A1 :: String -> String -> Int -> Int -> Annot1
A1 { ident :: String
ident = String
"foo"
                             , ann :: String
ann   = String
"int -> int"
                             , row :: Int
row   = Int
5
                             , col :: Int
col   = Int
14
                             })
                  ]
          )
         ,(Int
9,   [(Int, Annot1)] -> Assoc Int Annot1
forall k a. (Eq k, Hashable k) => [(k, a)] -> Assoc k a
i [( Int
22, A1 :: String -> String -> Int -> Int -> Annot1
A1 { ident :: String
ident = String
"map"
                            , ann :: String
ann   = String
"(a -> b) -> [a] -> [b]"
                            , row :: Int
row   = Int
9
                            , col :: Int
col   = Int
22
                            })
                  ,( Int
28, A1 :: String -> String -> Int -> Int -> Annot1
A1 { ident :: String
ident = String
"xs"
                            , ann :: String
ann   = String
"[b]"
                            , row :: Int
row   = Int
9
                            , col :: Int
col   = Int
28
                            })
                  ])
         ]

i :: (Eq k, Hashable k) => [(k, a)] -> Assoc k a
i :: [(k, a)] -> Assoc k a
i = HashMap k a -> Assoc k a
forall k a. HashMap k a -> Assoc k a
Asc (HashMap k a -> Assoc k a)
-> ([(k, a)] -> HashMap k a) -> [(k, a)] -> Assoc k a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(k, a)] -> HashMap k a
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList