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

{-# OPTIONS_GHC -Wno-orphans #-}

---------------------------------------------------------------------------
-- | 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           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 qualified Liquid.GHC.API              as SrcLoc
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 { o_vars :: Maybe [String]
o_vars   = forall a. Maybe a
Nothing
      -- , o_errors = []
      , o_types :: AnnInfo Doc
o_types  = forall {c} {tv} {r}.
(TyConable c, PPrint tv, PPrint c, PPrint r, Reftable r,
 Reftable (RTProp c tv r), Reftable (RTProp c tv ()),
 Hashable tv) =>
RType c tv r -> Doc
toDoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnInfo SpecType
annTy
      , o_templs :: AnnInfo Doc
o_templs = forall {c} {tv} {r}.
(TyConable c, PPrint tv, PPrint c, PPrint r, Reftable r,
 Reftable (RTProp c tv r), Reftable (RTProp c tv ()),
 Hashable tv) =>
RType c tv r -> Doc
toDoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnInfo SpecType
annTmpl
      , o_bots :: [SrcSpan]
o_bots   = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *).
Functor f =>
FixSolution -> f SpecType -> f SpecType
applySolution FixSolution
sol AnnInfo SpecType
annTmpl
    toDoc :: RType c tv r -> Doc
toDoc        = 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
  -- TODO(matt.walker): Make this obey json!
  = do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showWarns  forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SrcSpan]
bots (forall r. PrintfType r => String -> r
printf String
"WARNING: Found false in %s\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> String
showPpr)
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doAnnotate forall a b. (a -> b) -> a -> b
$ 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
       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     = forall a. Output a -> AnnInfo a
o_templs Output Doc
out
       annTyp :: AnnInfo Doc
annTyp     = forall a. Output a -> AnnInfo a
o_types  Output Doc
out
       res :: ErrorResult
res        = forall a. Output a -> ErrorResult
o_result Output Doc
out
       bots :: [SrcSpan]
bots       = forall a. Output a -> [SrcSpan]
o_bots   Output Doc
out
       showWarns :: Bool
showWarns  = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Config -> Bool
nowarnings    Config
cfg
       doAnnotate :: Bool
doAnnotate = Bool -> Bool
not 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 Bool -> String -> String -> AnnMap -> IO ()
generateHtml Bool
pandocF String
srcF String
tpHtmlF AnnMap
tplAnnMap
       Bool -> String -> String -> AnnMap -> IO ()
generateHtml Bool
pandocF String
srcF String
tyHtmlF AnnMap
typAnnMap
       String -> String -> IO ()
writeFile         String
vimF  forall a b. (a -> b) -> a -> b
$ Config -> AnnInfo Doc -> String
vimAnnot Config
cfg AnnInfo Doc
annTyp
       String -> ByteString -> IO ()
B.writeFile       String
jsonF forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode AnnMap
typAnnMap
    where
       pandocF :: Bool
pandocF    = Config -> Bool
pandocHtml Config
cfg
       tyHtmlF :: String
tyHtmlF    = Ext -> String -> String
extFileName Ext
Html                   String
srcF
       tpHtmlF :: String
tpHtmlF    = Ext -> String -> String
extFileName Ext
Html 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 :: forall r c tv. Reftable r => 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)]
_) <- forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
ordSrcSpan forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
M.toList HashMap SrcSpan [(Maybe Text, RType c tv r)]
m
                      , forall a. Falseable a => a -> Bool
isFalse (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 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a b. (a -> b) -> a -> b
$ 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 :: Bool -> FilePath -> FilePath -> ACSS.AnnMap -> IO ()
generateHtml :: Bool -> String -> String -> AnnMap -> IO ()
generateHtml Bool
pandocF 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 (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
pandocF Bool -> Bool -> Bool
&& 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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe String -> String -> String -> String -> IO ()
renderDirect String -> String -> String -> String -> String -> IO ()
renderPandoc' 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 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 [forall a b. b -> Either a b
Right (String -> String
cssHTML String
css)]
  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 :: forall (m :: * -> *). Monad m => String -> ExitCode -> m ()
checkExitCode String
_    ExitCode
ExitSuccess    = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkExitCode String
cmd (ExitFailure Int
n) = forall a. Maybe SrcSpan -> String -> a
panic forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String
"cmd: " forall a. [a] -> [a] -> [a]
++ String
cmd forall a. [a] -> [a] -> [a]
++ String
" failure code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n

pandocCmd :: FilePath -> FilePath -> FilePath -> String
pandocCmd :: String -> String -> String -> String
pandocCmd -- pandocPath mdFile htmlFile
  = 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
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t} {t}.
(PrintfArg t, PrintfArg t) =>
t -> t -> Text -> Text
strip String
beg String
code
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t} {t}.
(PrintfArg t, PrintfArg t) =>
t -> t -> Text -> Text
strip String
end String
code
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t} {t}.
(PrintfArg t, PrintfArg t) =>
t -> t -> Text -> Text
strip String
beg String
spec
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t} {t}.
(PrintfArg t, PrintfArg t) =>
t -> t -> Text -> Text
strip String
end String
spec
               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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$! (Bool -> String -> String -> String -> String
topAndTail Bool
full String
srcFile String
css 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 forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ forall a. IsString a => a
htmlClose)
topAndTail Bool
False 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>" forall a. [a] -> [a] -> [a]
++ String
title 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 :: forall a. IsString a => 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='"forall a. [a] -> [a] -> [a]
++ String
css 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     = 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  = forall t.
PPrint (TError t) =>
FixResult (TError t) -> [(Loc, Loc, String)]
mkAnnMapErr ErrorResult
res
                             , status :: Status
ACSS.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 :: forall t. FixResult t -> Status
mkStatus (Safe Stats
_)        = Status
ACSS.Safe
mkStatus (Unsafe Stats
_ [t]
_)    = Status
ACSS.Unsafe
mkStatus (Crash [(t, Maybe String)]
_ String
_)     = Status
ACSS.Error



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

cinfoErr :: PPrint (TError t) => TError t -> Maybe (Loc, Loc, String)
cinfoErr :: forall t. PPrint (TError t) => TError t -> Maybe (Loc, Loc, String)
cinfoErr TError t
e = case forall t. TError t -> SrcSpan
pos TError t
e of
               SrcLoc.RealSrcSpan RealSrcSpan
l Maybe BufSpan
_ -> forall a. a -> Maybe a
Just (RealSrcSpan -> Loc
srcSpanStartLoc RealSrcSpan
l, RealSrcSpan -> Loc
srcSpanEndLoc RealSrcSpan
l, forall a. PPrint a => a -> String
showpp TError t
e)
               SrcSpan
_                      -> 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 = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first RealSrcSpan -> Loc
srcSpanStartLoc) 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)
  = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall {a}. Symbolic a => (Maybe a, Doc) -> (String, String)
bindStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (RealSrcSpan -> Int
srcSpanEndCol forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst))
  forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith (RealSrcSpan -> (Int, Int)
lineCol forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) | (SrcLoc.RealSrcSpan RealSrcSpan
l Maybe BufSpan
_, (Maybe Text, Doc)
x:[(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) = (forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"_" (Symbol -> String
symbolString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Symbol
shorten forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. a -> a
id

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

closeA :: AnnInfo (Annot b) -> AnnInfo b
closeA :: forall b. AnnInfo (Annot b) -> AnnInfo b
closeA a :: AnnInfo (Annot b)
a@(AI HashMap SrcSpan [(Maybe Text, Annot b)]
m)   = Annot b -> b
cf 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 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)]
_               -> forall a. Maybe SrcSpan -> String -> a
panic forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ String
"malformed AnnInfo: " forall a. [a] -> [a] -> [a]
++ 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 :: forall t. AnnInfo (Annot t) -> AnnInfo (Annot t)
filterA (AI HashMap SrcSpan [(Maybe Text, Annot t)]
m) = forall a. HashMap SrcSpan [(Maybe Text, a)] -> AnnInfo a
AI (forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
M.filter 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 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 :: forall t. AnnInfo (Annot t) -> AnnInfo (Annot t)
collapseA (AI HashMap SrcSpan [(Maybe Text, Annot t)]
m) = forall a. HashMap SrcSpan [(Maybe Text, a)] -> AnnInfo a
AI (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 :: forall t t1. [(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)] forall a. [a] -> [a] -> [a]
++ String -> [(TokenType, String)]
tokBody String
body 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)
  | forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ss forall a. Num a => a -> a -> a
- Int
3) String
ss forall a. Eq a => a -> a -> Bool
== String
"@-}"
  = forall a. a -> Maybe a
Just (String
liquidBegin, forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ss forall a. Num a => a -> a -> a
- Int
3) String
ss, String
liquidEnd)
trimLiquidAnnot 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   = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) String
s 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 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 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) forall a. a -> [a] -> [a]
: [String] -> [(TokenType, String)]
tokAlt [String]
ss
    tokAlt' [String]
_      = []

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

newtype 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 = forall a. [a] -> [[a]] -> [a]
L.intercalate String
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a t.
(Show a, PrintfType t) =>
(RealSrcSpan, (String, a)) -> t
vimBind 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 :: forall a t.
(Show a, PrintfType t) =>
(RealSrcSpan, (String, a)) -> t
vimBind (RealSrcSpan
sp, (String
v, a
ann)) = forall r. PrintfType r => String -> r
printf String
"%d:%d-%d:%d::%s" Int
l1 Int
c1 Int
l2 Int
c2 (String
v forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ 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 [ Key
"ident" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
i
                               , Key
"ann"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
a
                               , Key
"row"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
r
                               , Key
"col"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
c
                               ]

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

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




dropErrorLoc :: String -> String
dropErrorLoc :: String -> String
dropErrorLoc String
msg
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
msg' = String
msg
  | Bool
otherwise = forall a. [a] -> [a]
tail String
msg'
  where
    (String
_, String
msg') = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char
' ' 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 [ forall {c} {a}. (IsString c, Show a) => a -> c
tshow' k
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON a
a | (k
k, a
a) <- forall k v. HashMap k v -> [(k, v)]
M.toList HashMap k a
kas ]
    where
      tshow' :: a -> c
tshow'       = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

instance ToJSON ACSS.AnnMap where
  toJSON :: AnnMap -> Value
toJSON AnnMap
a = [Pair] -> Value
object [ Key
"types"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (AnnMap -> AnnTypes
annTypes     AnnMap
a)
                    , Key
"errors"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (AnnMap -> AnnErrors
annErrors    AnnMap
a)
                    , Key
"status"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (AnnMap -> Status
ACSS.status  AnnMap
a)
                    , Key
"sptypes" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (forall {a} {a}.
(ToJSON a, ToJSON a) =>
(RealSrcSpan, (a, a)) -> Value
toJ 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 [ Key
"start" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (RealSrcSpan -> Loc
srcSpanStartLoc RealSrcSpan
sp)
                               , Key
"stop"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON (RealSrcSpan -> Loc
srcSpanEndLoc   RealSrcSpan
sp)
                               , Key
"ident" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON a
x
                               , Key
"ann"  forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON a
t
                               ]

annErrors :: ACSS.AnnMap -> AnnErrors
annErrors :: AnnMap -> AnnErrors
annErrors = [(Loc, Loc, String)] -> AnnErrors
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       = forall {t :: * -> *} {k} {k1} {a}.
(Foldable t, 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          = 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) -> 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) (forall k a. HashMap k a -> Assoc k a
Asc 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)) <- forall k v. HashMap k v -> [(k, v)]
M.toList 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 :: 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 (Asc HashMap k (Assoc k1 a)
m)  = forall k a. HashMap k a -> Assoc k a
Asc (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert k
r (forall k a. HashMap k a -> Assoc k a
Asc (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         = forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
M.lookupDefault (forall k a. HashMap k a -> Assoc k a
Asc 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 (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 =
  forall k a. (Eq k, Hashable k) => [(k, a)] -> Assoc k a
mkAssoc
    [ (Int
5, forall k a. (Eq k, Hashable k) => [(k, a)] -> Assoc k a
mkAssoc
            [ ( Int
14, A1 { ident :: String
ident = String
"foo"
                       , ann :: String
ann   = String
"int -> int"
                       , row :: Int
row   = Int
5
                       , col :: Int
col   = Int
14
                       })
            ]
      )
    , (Int
9, forall k a. (Eq k, Hashable k) => [(k, a)] -> Assoc k a
mkAssoc
            [ ( Int
22, 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 { ident :: String
ident = String
"xs"
                       , ann :: String
ann   = String
"[b]"
                       , row :: Int
row   = Int
9
                       , col :: Int
col   = Int
28
                       })
            ])
    ]

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