path: root/src/HaskellCodeExplorer/Types.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module HaskellCodeExplorer.Types where

import Control.DeepSeq (NFData)
import qualified Data.Aeson as A
import Data.Aeson.Types (Options, defaultOptions, omitNothingFields)
import Data.Generics
  ( Constr
  , Data(..)
  , DataType
  , Fixity(..)
  , constrIndex
--  , gcast2
  , mkConstr
  , mkDataType
  )
import qualified Data.HashMap.Strict as HM
import Data.Hashable (Hashable)
import qualified Data.IntMap.Strict as IM
import qualified Data.IntervalMap.Strict as IVM
import qualified Data.List as L
import Data.Maybe (fromMaybe, isJust)
import Data.Serialize (Get, Serialize(..))
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text.Lazy (toStrict)
import qualified Data.Vector as V
import Data.Version (Version(..),showVersion)
import Documentation.Haddock.Types
  ( DocH(..)
  , Example(..)
  , Header(..)
  , ModLink(..)
  , Hyperlink(..)
  , Picture(..)
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
  , Table(..)
  , TableCell(..)
  , TableRow(..)
#endif
  )
import GHC.Generics (Generic)
import Prelude hiding (id)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import qualified Text.Blaze.Html5 as Html
import qualified Text.Blaze.Html5.Attributes as Attr

--------------------------------------------------------------------------------
-- Package info
--------------------------------------------------------------------------------

data PackageInfo modInfo = PackageInfo
  { id :: PackageId
  , moduleMap :: HM.HashMap HaskellModulePath modInfo
  , moduleNameMap :: HM.HashMap HaskellModuleName (HM.HashMap ComponentId HaskellModulePath)
  , directoryTree :: DirTree
  , externalIdInfoMap :: Trie Char ExternalIdentifierInfo
  -- ^ All external identifiers defined in the package
  , externalIdOccMap :: HM.HashMap ExternalId (S.Set IdentifierSrcSpan)
  -- ^ All occurrences of each external identifier in the package
  } deriving (Show, Eq, Generic, Data)

data PackageId = PackageId
  { name :: T.Text
  , version :: Data.Version.Version
  } deriving (Show, Eq, Ord, Generic, Data)

packageIdToText :: PackageId -> T.Text
packageIdToText (PackageId name version) =
  T.concat [name, "-", T.pack $ showVersion version]

packageName :: PackageInfo a -> T.Text
packageName =
  (name :: (PackageId -> T.Text)) . (id :: PackageInfo a -> PackageId)

data IdentifierSrcSpan = IdentifierSrcSpan
  { modulePath :: HaskellModulePath
  , line :: Int
  , startColumn :: Int
  , endColumn :: Int
  } deriving (Show, Eq, Ord, Generic, Data)

data DirTree
  = Dir { name :: FilePath
        , contents :: [DirTree] }
  | File { name :: FilePath
         , path :: FilePath
         , isHaskellModule :: Bool }
  deriving (Show, Eq, Generic, Data)

newtype ComponentId = ComponentId
  { getComponentId :: T.Text
  } deriving (Show, Eq, Ord, Generic, A.ToJSONKey, Data, Hashable)

data ComponentType
  = Setup
  | Lib
  | SubLib T.Text
  | FLib T.Text
  | Exe T.Text
  | Test T.Text
  | Bench T.Text
  deriving (Show, Eq, Generic, Data)

isLibrary :: ComponentType -> Bool
isLibrary Lib = True
isLibrary (SubLib _) = True
isLibrary (FLib _) = True
isLibrary _ = False

packageInfoBinaryFileName :: FilePath
packageInfoBinaryFileName = "packageInfo"

packageInfoJsonFileName :: FilePath
packageInfoJsonFileName = "packageInfo.json"

defaultOutputDirectoryName :: FilePath
defaultOutputDirectoryName = ".haskell-code-explorer"

--------------------------------------------------------------------------------
-- A simple Trie implementation
--------------------------------------------------------------------------------

data Trie k v = Trie
  { values :: S.Set v
  , children :: HM.HashMap k (Trie k v)
  } deriving (Show, Eq, Generic, Data)

emptyTrie :: Trie k v
emptyTrie = Trie S.empty HM.empty

insertToTrie ::
     (Hashable k, Eq k, Ord v)
  => (v -> S.Set v -> S.Set v)
  -> [k]
  -> v
  -> Trie k v
  -> Trie k v
insertToTrie f [] v (Trie vals children) = Trie (f v vals) children
insertToTrie f word@(first:rest) val (Trie vals children) =
  case HM.lookup first children of
    Just trie ->
      Trie vals (HM.insert first (insertToTrie f rest val trie) children)
    Nothing ->
      insertToTrie f word val (Trie vals (HM.insert first emptyTrie children))

match :: (Hashable k, Eq k, Ord v) => [k] -> Trie k v -> S.Set v
match (first:rest) (Trie _ children) =
  maybe S.empty (match rest) (HM.lookup first children)
match [] (Trie val children) =
  S.union val $
  S.unions
    [S.union v $ match [] trie | (_, trie@(Trie v _)) <- HM.toList children]

--------------------------------------------------------------------------------
-- Module info
--------------------------------------------------------------------------------

data ModuleInfo = ModuleInfo
  { id :: HaskellModulePath
  , name :: HaskellModuleName
  , source :: V.Vector T.Text
    -- ^ Source code of the module
  , transformation :: SourceCodeTransformation
  , exprInfoMap :: ExpressionInfoMap
    -- ^ Type of each expression in the module
  , idOccMap :: IdentifierOccurrenceMap
    -- ^ All occurrences of each identifier in the module
  , idInfoMap :: IdentifierInfoMap
    -- ^ Information about each identifier in the module
  , declarations :: [Declaration]
  , definitionSiteMap :: DefinitionSiteMap
    -- ^ Definition site of each top-level value, type, and type class instance
  , externalIds :: [ExternalIdentifierInfo]
  } deriving (Show, Eq, Generic, Data)

type ExpressionInfoMap = IVM.IntervalMap (Int, Int) ExpressionInfo
type IdentifierOccurrenceMap = IM.IntMap [((Int, Int), IdentifierOccurrence)]
type IdentifierInfoMap = HM.HashMap InternalId IdentifierInfo

data DefinitionSiteMap = DefinitionSiteMap
  { values :: HM.HashMap OccName DefinitionSite
  , types :: HM.HashMap OccName DefinitionSite
  , instances :: HM.HashMap T.Text DefinitionSite
  } deriving (Show, Eq, Generic, Data)

data DefinitionSite = DefinitionSite
  { location :: LocationInfo
  , documentation :: Maybe HTML
  } deriving (Show, Eq, Generic, Data)

type HTML = T.Text

newtype OccName = OccName
  { getOccName :: T.Text
  } deriving (Show, Eq, Ord, Generic, A.ToJSONKey, Data, Hashable)

-- | 'CompactModuleInfo' contains a subset of fields of 'ModuleInfo'.
data CompactModuleInfo = CompactModuleInfo
  { id :: HaskellModulePath
  , name :: HaskellModuleName
  , exprInfoMap :: ExpressionInfoMap
  , definitionSiteMap :: DefinitionSiteMap
  , source :: V.Vector T.Text
  } deriving (Show, Eq, Generic, Data)

haskellPreprocessorExtensions :: [FilePath]
haskellPreprocessorExtensions =
  [".hsc", ".chs", ".cpphs", ".gc", ".x", ".y", ".ly"]

toCompactPackageInfo :: PackageInfo ModuleInfo -> PackageInfo CompactModuleInfo
toCompactPackageInfo PackageInfo {..} =
  PackageInfo
    { id = id
    , moduleMap = HM.map toCompactModuleInfo moduleMap
    , moduleNameMap = moduleNameMap
    , directoryTree = directoryTree
    , externalIdOccMap = externalIdOccMap
    , externalIdInfoMap = externalIdInfoMap
    }

toCompactModuleInfo :: ModuleInfo -> CompactModuleInfo
toCompactModuleInfo ModuleInfo {..} =
  CompactModuleInfo
    { id = id
    , name = name
    , exprInfoMap = exprInfoMap
    , definitionSiteMap = definitionSiteMap
    , source = source
    }

newtype HaskellModuleName = HaskellModuleName
  { getHaskellModuleName :: T.Text
  } deriving (Show, Eq, Ord, Generic, A.ToJSONKey, Data)

newtype HaskellModulePath = HaskellModulePath
  { getHaskellModulePath :: T.Text
  } deriving (Show, Eq, Ord, Generic, A.ToJSONKey, Data)

newtype HaskellFilePath = HaskellFilePath
  { getHaskellFilePath :: T.Text
  } deriving (Show, Eq, Ord, Generic, A.ToJSONKey, Data)

-- | Haskell identifier (value or type)
data IdentifierInfo = IdentifierInfo
  { sort :: NameSort
  , occName :: OccName
  , demangledOccName :: T.Text
  , nameSpace :: NameSpace
  , locationInfo :: LocationInfo
  , idType :: Type
  , details :: Maybe IdDetails
  , doc :: Maybe HTML
  , internalId :: InternalId
  , externalId :: Maybe ExternalId
  , isExported :: Bool
  } deriving (Show, Eq, Ord, Generic, Data)

data NameSort
  = External
  | Internal
  deriving (Show, Eq, Ord, Generic, Data)

data NameSpace
  = VarName
  | DataName
  | TvName
  | TcClsName
  deriving (Show, Eq, Ord, Generic, Data)

data IdDetails
  = VanillaId
  | RecSelId
  | RecSelIdNaughty
  | DataConWorkId
  | DataConWrapId
  | ClassOpId
  | PrimOpId
  | FCallId
  | TickBoxOpId
  | DFunId
  | CoVarId
  | JoinId
  deriving (Show, Eq, Ord, Generic, Data)

-- | Each Haskell identifier has an 'InternalId' that is unique within a single module
newtype InternalId = InternalId
  { getInternalId :: T.Text
  } deriving (Show, Eq, Ord, Generic, Data, Hashable, A.ToJSONKey)

newtype ExternalId = ExternalId
  { getExternalId :: T.Text
  } deriving (Show, Eq, Ord, Generic, Data, Hashable, A.ToJSONKey)

newtype ExternalIdentifierInfo = ExternalIdentifierInfo
  { getIdentifierInfo :: IdentifierInfo
  } deriving (Eq, Show, Generic, Data)

instance Ord ExternalIdentifierInfo where
  compare (ExternalIdentifierInfo i1) (ExternalIdentifierInfo i2) =
    case compare
           (T.length . demangledOccName $ i1)
           (T.length . demangledOccName $ i2) of
      GT -> GT
      LT -> LT
      EQ ->
        case compare (demangledOccName i1) (demangledOccName i2) of
          GT -> GT
          LT -> LT
          EQ ->
            compare
              (internalId (i1 :: IdentifierInfo))
              (internalId (i2 :: IdentifierInfo))

data ExpressionInfo = ExpressionInfo
  { description :: T.Text
  , exprType :: Maybe Type
  } deriving (Show, Eq, Generic, Data)

-- | Occurrence of an identifier in a source code
data IdentifierOccurrence = IdentifierOccurrence
  { internalId :: Maybe InternalId
  , internalIdFromRenamedSource :: Maybe InternalId
  , isBinder :: Bool
  , instanceResolution :: Maybe InstanceResolution
  , idOccType :: Maybe Type
  -- ^ Instantiated type of an identifier
  , typeArguments :: Maybe [Type]
  , description :: T.Text
  , sort :: IdentifierOccurrenceSort
  } deriving (Show, Eq, Ord, Generic, Data)

data IdentifierOccurrenceSort
  = ValueId
  | TypeId
  | ModuleId LocationInfo
  deriving (Show, Eq, Ord, Generic, Data)

data Type = Type
  { components :: [TypeComponent]
  , componentsExpanded :: Maybe [TypeComponent]
  -- ^ Components of a type with all type synonyms expanded
  } deriving (Show, Eq, Ord, Generic, Data)

data TypeComponent
  = Text T.Text
  | TyCon { internalId :: InternalId
          , name :: T.Text }
  deriving (Show, Eq, Ord, Generic, Data)

-- | Tree of instances
data InstanceResolution =
  Instance
  { name :: T.Text
  -- ^ Type of an instance, e.g., "instance Show a => ClassName a"
  , instanceType :: Type
  , types :: [Type]
  -- ^ Types at which type variables of a class are instantiated
  , location :: LocationInfo
  , instances :: [InstanceResolution]
  }
  | Stop
  deriving (Show,Eq,Ord,Generic,Data)

data SourceCodeTransformation = SourceCodeTransformation
  { totalLines :: Int
  , filePath :: HaskellModulePath
  , linePragmas :: S.Set LinePragma
  , fileIndex :: HM.HashMap HaskellFilePath (S.Set FileLocation)
  -- ^ Map from an original filename to its locations in a preprocessed source code
  } deriving (Show, Eq, Generic, Data)

-- | Location of a file included by a preprocessor
data FileLocation = FileLocation
  { lineStart :: Int
  , lineEnd :: Int
  , offset :: Int
  -- ^ (line number in a preprocessed file) - (line number in an original file) + 1
  } deriving (Show, Eq, Generic, Data)

-- | Line pragma inserted by a preprocessor
data LinePragma = LinePragma
  { filePath :: HaskellFilePath
  , lineNumberPreprocessed :: Int
  , lineNumberOriginal :: Int
  } deriving (Show, Eq, Generic, Data)

fromOriginalLineNumber ::
     SourceCodeTransformation -> (HaskellFilePath, Int) -> Either T.Text Int
fromOriginalLineNumber SourceCodeTransformation {linePragmas = pragmas} (_originalFileName, originalLineNumber)
  | S.null pragmas = Right originalLineNumber
fromOriginalLineNumber SourceCodeTransformation {fileIndex = index} (originalFileName, originalLineNumber) =
  case HM.lookup originalFileName index of
    Just set ->
      -- lookupGE finds smallest element greater or equal to the given one
      case S.lookupGE (FileLocation 1 originalLineNumber 1) set of
        Just FileLocation {..} -> Right $ originalLineNumber + offset
        Nothing ->
          Left $
          T.concat
            [ "Cannot find "
            , T.pack . show $ (originalFileName, originalLineNumber)
            , " in "
            , T.pack $ show index
            ]
    Nothing ->
      Left $
      T.concat
        [ "Cannot find file "
        , T.pack . show $ originalFileName
        , " in "
        , T.pack $ show index
        ]

data Declaration = Declaration
  { sort :: DeclarationSort
  , name :: T.Text
  , declType :: Maybe Type
  , isExported :: Bool
  , lineNumber :: Int
  } deriving (Show, Eq, Ord, Generic, Data)

data DeclarationSort
  = TyClD
  | InstD
  | ValD
  | ForD
  deriving (Show, Eq, Ord, Generic, Data)

data LocationInfo
  = ExactLocation { packageId :: PackageId
                  , modulePath :: HaskellModulePath
                  , moduleName :: HaskellModuleName
                  , startLine :: Int
                  , endLine :: Int
                  , startColumn :: Int
                  , endColumn :: Int }
  | ApproximateLocation { packageId :: PackageId
                        , moduleName :: HaskellModuleName
                        , entity :: LocatableEntity
                        , name :: T.Text
                        , haddockAnchorId :: Maybe T.Text
                        , componentId :: ComponentId }
  | UnknownLocation T.Text
  deriving (Show, Eq, Ord, Generic, Data)

data LocatableEntity
  = Typ
  | Val
  | Inst
  | Mod
  deriving (Show, Eq, Ord, Generic, Data)

--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------

deriving instance (Data k) => Data (IVM.Interval k)

instance (Data k, Data v, Eq k, Ord k, Data (IVM.Interval k)) =>
         Data (IVM.IntervalMap k v) where
  gfoldl f z m = z IVM.fromList `f` IVM.toList m
  toConstr _ = fromListConstr
  gunfold k z c =
    case constrIndex c of
      1 -> k (z IVM.fromList)
      _ -> error "gunfold"
  dataTypeOf _ = intervalMapDataType
  -- dataCast2 = gcast2

fromListConstr :: Constr
fromListConstr = mkConstr intervalMapDataType "fromList" [] Prefix

intervalMapDataType :: DataType
intervalMapDataType = mkDataType "Data.IntervalMap" [fromListConstr]

deriving instance Generic (IVM.Interval k)

instance Hashable HaskellModuleName
instance Serialize HaskellModuleName
instance Hashable HaskellModulePath
instance Serialize HaskellModulePath
instance Hashable HaskellFilePath
instance Serialize HaskellFilePath
instance (Serialize k, Serialize v, Ord k) =>
         Serialize (IVM.IntervalMap k v) where
  put = put . IVM.toAscList
  get = IVM.fromAscList <$> Data.Serialize.get
instance Ord LinePragma where
  compare p1 p2 =
    compare
      (lineNumberPreprocessed (p1 :: LinePragma))
      (lineNumberPreprocessed (p2 :: LinePragma))
instance Ord FileLocation where
  compare l1 l2 = compare (lineEnd l1) (lineEnd l2)
instance Serialize LinePragma
instance Serialize FileLocation
instance Serialize SourceCodeTransformation
instance Serialize IdentifierInfo
instance Serialize InternalId
instance Serialize ExternalId
instance Serialize ExternalIdentifierInfo where
  put (ExternalIdentifierInfo info) = put info
  get = ExternalIdentifierInfo <$>(get :: Get IdentifierInfo)
instance Serialize InstanceResolution
instance Serialize OccName
instance Serialize IdDetails
instance Serialize NameSpace
instance Serialize DefinitionSiteMap
instance Serialize DefinitionSite
instance Serialize Declaration
instance Serialize NameSort
instance Serialize DeclarationSort
instance Serialize PackageId
instance Serialize Data.Version.Version
instance Serialize (PackageInfo ModuleInfo)
instance Serialize (PackageInfo CompactModuleInfo)
instance Serialize IdentifierSrcSpan
instance Serialize DirTree
instance Serialize ComponentId
instance Serialize ComponentType
instance Serialize T.Text where
  put = put . encodeUtf8
  get = decodeUtf8 <$> Data.Serialize.get
instance (Serialize k, Serialize v, Eq k,Hashable k) => Serialize (HM.HashMap k v) where
  put = put . HM.toList
  get = HM.fromList <$> get
instance Serialize ModuleInfo
instance Serialize CompactModuleInfo
instance (Serialize k) => Serialize (IVM.Interval k)
instance Serialize LocationInfo
instance Serialize IdentifierOccurrence
instance Serialize IdentifierOccurrenceSort
instance Serialize TypeComponent
instance (Serialize a) => Serialize (V.Vector a) where
  put = put . V.toList
  get = (\l -> V.fromListN (L.length l) l) <$> get
instance Serialize Type
instance Serialize ExpressionInfo
instance Serialize LocatableEntity
instance (Serialize k,Ord k,Serialize v,Ord v,Hashable k) => Serialize (Trie k v)
instance NFData HaskellModuleName
instance NFData HaskellModulePath
instance NFData HaskellFilePath
instance NFData LinePragma
instance NFData FileLocation
instance NFData SourceCodeTransformation
instance NFData IdentifierInfo
instance NFData InternalId
instance NFData ExternalId
instance NFData ExternalIdentifierInfo
instance NFData InstanceResolution
instance NFData IdDetails
instance NFData NameSpace
instance NFData OccName
instance NFData DefinitionSiteMap
instance NFData DefinitionSite
instance NFData Declaration
instance NFData NameSort
instance NFData DeclarationSort
instance NFData PackageId
instance NFData (PackageInfo ModuleInfo)
instance NFData (PackageInfo CompactModuleInfo)
instance NFData IdentifierSrcSpan
instance NFData DirTree
instance NFData ComponentId
instance NFData ComponentType
instance NFData ModuleInfo
instance NFData CompactModuleInfo
instance NFData LocationInfo
instance NFData IdentifierOccurrence
instance NFData IdentifierOccurrenceSort
instance NFData TypeComponent
instance NFData Type
instance NFData ExpressionInfo
instance NFData LocatableEntity
instance (NFData k, Ord k, NFData v, Ord v, Hashable k) =>
         NFData (Trie k v)

omitNothingOptions :: Options
omitNothingOptions = defaultOptions {omitNothingFields = True}

instance A.ToJSON (PackageInfo a) where
  toJSON PackageInfo {..} =
    A.object
      [ ("id", A.toJSON $ packageIdToText id)
      , ("directoryTree", A.toJSON directoryTree)
      , ("modules", A.toJSON . HM.map (const ()) $ moduleMap)
      ]

instance A.ToJSON ModuleInfo where
  toJSON ModuleInfo {..} =
    let sourceCodeLines = zip [1 ..] $ V.toList source
        tokenizedLines =
          L.map
            (\(lineNumber, lineText) ->
               case IM.lookup lineNumber idOccMap of
                 Just identifiers -> (lineNumber, tokenize lineText identifiers)
                 Nothing ->
                   ( lineNumber
                   , [(lineText, (1, T.length lineText + 1), Nothing)]))
            sourceCodeLines
        html =
          Html.table Html.! Attr.class_ "source-code" $
          Html.tbody $ mapM_ (uncurry lineToHtml) tokenizedLines
     in A.object
          [ ("id", A.toJSON id)
          , ("name", A.toJSON name)
          , ("sourceCodeHtml", A.toJSON . renderHtml $ html)
          , ("identifiers", A.toJSON idInfoMap)
          , ("occurrences", A.toJSON $ idOccurrencesHashMap idOccMap)
          , ("declarations", A.toJSON declarations)
          ]

idOccurrencesHashMap ::
     IM.IntMap [((Int, Int), IdentifierOccurrence)]
  -> HM.HashMap T.Text IdentifierOccurrence
idOccurrencesHashMap =
  HM.fromList .
  concatMap
    (\(lineNum, occs) ->
       L.map
         (\((startCol, endCol), occ) ->
            (occurrenceLocationToText lineNum startCol endCol, occ))
         occs) .
  IM.toList

idOccurrenceList ::
     IM.IntMap [((Int, Int), IdentifierOccurrence)]
  -> HM.HashMap T.Text IdentifierOccurrence
idOccurrenceList =
  HM.fromList .
  concatMap
    (\(lineNum, occs) ->
       L.map
         (\((startCol, endCol), occ) ->
            (occurrenceLocationToText lineNum startCol endCol, occ))
         occs) .
  IM.toList

occurrenceLocationToText :: Int -> Int -> Int -> T.Text
occurrenceLocationToText lineNum startCol endCol =
  T.concat
    [ T.pack . show $ lineNum
    , "-"
    , T.pack . show $ startCol
    , "-"
    , T.pack . show $ endCol
    ]

lineToHtml :: Int
           -> [(T.Text, (Int, Int), Maybe IdentifierOccurrence)]
           -> Html.Html
lineToHtml lineNumber tokens =
  Html.tr $ do
    Html.td Html.! Attr.class_ "line-number" Html.!
      Attr.id (Html.textValue . T.append "LN" . T.pack $ show lineNumber) $
      Html.toHtml (T.pack $ show lineNumber)
    Html.td Html.! Attr.class_ "line-content" Html.!
      Html.dataAttribute "line" (Html.textValue $ T.pack . show $ lineNumber) Html.!
      Attr.id (Html.textValue . T.append "LC" . T.pack $ show lineNumber) $
      mapM_
        (\(content, (start, end), mbIdOcc) ->
           let addPositionAttrs :: Html.Html -> Html.Html
               addPositionAttrs htmlElement =
                 htmlElement Html.!
                 Html.dataAttribute
                   "start"
                   (Html.textValue $ T.pack . show $ start) Html.!
                 Html.dataAttribute "end" (Html.textValue $ T.pack . show $ end)
            in case mbIdOcc of
                 Just idOcc ->
                   addPositionAttrs $
                   Html.span Html.! Attr.class_ "identifier" Html.!
                   Attr.id
                     (Html.textValue .
                      maybe "" getInternalId . internalIdFromRenamedSource $
                      idOcc) Html.!
                   Html.dataAttribute
                     "occurrence"
                     (Html.textValue $
                      occurrenceLocationToText lineNumber start end) Html.!
                   Html.dataAttribute
                     "identifier"
                     (Html.textValue $
                      maybe "" getInternalId $
                      internalId (idOcc :: IdentifierOccurrence)) $
                   Html.toHtml content
                 Nothing -> addPositionAttrs . Html.span . Html.toHtml $ content)
        tokens

tokenize
  :: forall a.
     T.Text -- ^ Source code
  -> [((Int, Int), a)] -- ^ Identifier locations
                       -- The end position is defined to be the column /after/ the end of the
                       -- span. That is, a span of (1,1)-(1,2) is one character long, and a
                       -- span of (1,1)-(1,1) is zero characters long.
  -> [(T.Text, (Int, Int), Maybe a)]
tokenize line =
  L.reverse .
  (\(remainingLine, currentIndex, c) ->
     if T.null remainingLine
       then c
       else (remainingLine, (currentIndex, T.length line + 1), Nothing) : c) .
  L.foldl' split (line, 1, [])
  where
    split ::
         (T.Text, Int, [(T.Text, (Int, Int), Maybe a)])
      -> ((Int, Int), a)
      -> (T.Text, Int, [(T.Text, (Int, Int), Maybe a)])
    split (remainingLine, currentIndex, chunks) ((start, end), a)
      | start == currentIndex =
        let (chunk, remainingLine') = T.splitAt (end - start) remainingLine
            chunks' = (chunk, (start, end), Just a) : chunks
         in (remainingLine', end, chunks')
      | otherwise =
        let (chunkNoId, remainingLine') =
              T.splitAt (start - currentIndex) remainingLine
            (chunk, remainingLine'') = T.splitAt (end - start) remainingLine'
         in ( remainingLine''
            , end
            , (chunk, (start, end), Just a) :
              (chunkNoId, (currentIndex, start), Nothing) : chunks)

docToHtml ::
     forall mod id.
     (mod -> Html.Html)
  -> (id -> Html.Html)
  -> DocH mod id
  -> HTML
docToHtml modToHtml idToHtml = toStrict . renderHtml . toH
  where
    toH :: DocH mod id -> Html.Html
    toH (DocAppend doc1 doc2) = toH doc1 >> toH doc2
    toH (DocParagraph doc) = Html.p $ toH doc
    toH (DocIdentifier identifier) = Html.span $ idToHtml identifier
    toH (DocWarning doc) = Html.div Html.! Attr.class_ "warning" $ toH doc
    toH (DocEmphasis doc) = Html.em $ toH doc
    toH DocEmpty = mempty
    toH (DocBold doc) = Html.b $ toH doc
    toH (DocMonospaced doc) =
      Html.span Html.! Attr.class_ "source-code-font" $ toH doc
    toH (DocUnorderedList docs) = Html.ul $ mapM_ (Html.li . toH) docs
    toH (DocOrderedList docs) = Html.ol $ mapM_ (Html.li . toH) docs
    toH (DocDefList docs) =
      Html.dl $
      mapM_ (\(doc1, doc2) -> Html.dt (toH doc1) >> Html.dd (toH doc2)) docs
    toH (DocCodeBlock doc) = Html.div Html.! Attr.class_ "source-code" $ toH doc
    toH (DocIdentifierUnchecked modName) = modToHtml modName
    toH (DocModule (ModLink url label)) =
      -- Html.span . Html.toHtml . T.pack $ str
      Html.a Html.! (Attr.href . Html.textValue . T.pack $ url) $
      fromMaybe (Html.toHtml url) $ toH <$> label
    toH (DocHyperlink (Hyperlink url label)) =
      Html.a Html.! (Attr.href . Html.textValue . T.pack $ url) $
      fromMaybe (Html.toHtml url) $ toH <$> label
    toH (DocPic (Picture uri mbTitle)) =
      Html.img Html.! (Attr.src . Html.textValue . T.pack $ uri) Html.!
      (Attr.title . Html.textValue . T.pack $ fromMaybe "" mbTitle)
    toH (DocMathInline str) =
      Html.span . Html.toHtml $ T.pack ("\\(" ++ str ++ "\\)")
    toH (DocMathDisplay str) =
      Html.div . Html.toHtml $ T.pack ("\\[" ++ str ++ "\\]")
    toH (DocAName str) =
      Html.a Html.! (Attr.id . Html.textValue . T.pack $ str) $ mempty
    toH (DocProperty str) =
      Html.div Html.! Attr.class_ "source-code" $ Html.toHtml $ T.pack str
    toH (DocExamples examples) =
      Html.div Html.! Attr.class_ "source-code" $
      mapM_
        (\(Example expr results) ->
           let htmlPrompt = Html.span $ Html.toHtml (">>> " :: String)
               htmlExpression = Html.span $ Html.toHtml (expr ++ "\n")
            in htmlPrompt >> htmlExpression >>
               mapM_ (Html.span . Html.toHtml) (unlines results))
        examples
    toH (DocString str) = Html.span . Html.toHtml $ T.pack str
    toH (DocHeader (Header level doc)) = toHeader level $ toH doc
      where
        toHeader 1 = Html.h1
        toHeader 2 = Html.h2
        toHeader 3 = Html.h3
        toHeader 4 = Html.h4
        toHeader 5 = Html.h5
        toHeader _ = Html.h6
#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
    toH (DocTable (Table hs bs)) =
      let tableRowToH tdOrTh (TableRow cells) =
            Html.tr $ mapM_ (tableCellToH tdOrTh) cells
          tableCellToH tdOrTh (TableCell colspan rowspan doc) =
            (tdOrTh $ toH doc) Html.!?
            (colspan /= 1, (Attr.colspan (Html.stringValue $ show colspan))) Html.!?
            (rowspan /= 1, (Attr.rowspan (Html.stringValue $ show rowspan)))
       in Html.table $
          Html.thead (mapM_ (tableRowToH Html.th) hs) >>
          Html.tbody (mapM_ (tableRowToH Html.td) bs)
#endif

instance A.ToJSON HaskellModuleName where
  toJSON (HaskellModuleName name) = A.String name
instance A.ToJSON HaskellModulePath where
  toJSON (HaskellModulePath path) = A.String path
instance A.ToJSON HaskellFilePath where
  toJSON (HaskellFilePath path) = A.String path
instance A.ToJSON LinePragma where
  toJSON = A.genericToJSON omitNothingOptions
instance A.ToJSON FileLocation where
  toJSON = A.genericToJSON omitNothingOptions
instance A.ToJSON IdentifierInfo where
  toJSON = A.genericToJSON omitNothingOptions
instance A.ToJSON InternalId where
  toJSON (InternalId text) = A.toJSON text
instance A.ToJSON ExternalId where
  toJSON (ExternalId text) = A.toJSON text
instance A.ToJSON ExternalIdentifierInfo where
  toJSON (ExternalIdentifierInfo info) = A.toJSON info
instance A.ToJSON InstanceResolution where
  toJSON (Instance name typ types location instances) =
    A.object
      [ "name" A..= A.toJSON name
      , "types" A..= A.toJSON types
      , "location" A..= A.toJSON location
      , "instanceType" A..= A.toJSON typ
      , "instances" A..=
        (A.Array . V.fromList . Prelude.map A.toJSON $ instances)
      ]
  toJSON Stop = A.Null
instance A.ToJSON IdDetails where
  toJSON = A.genericToJSON omitNothingOptions
instance A.ToJSON NameSpace where
  toJSON = A.genericToJSON omitNothingOptions
instance A.ToJSON Declaration
instance A.ToJSON NameSort
instance A.ToJSON OccName where
  toJSON (OccName name) = A.String name
instance A.ToJSON DeclarationSort
instance A.ToJSON PackageId
instance A.ToJSON ComponentId where
  toJSON (ComponentId id) = A.toJSON id
instance A.ToJSON ComponentType
instance A.ToJSON LocationInfo where
  toJSON = A.genericToJSON omitNothingOptions
instance A.ToJSON LocatableEntity
instance A.ToJSON IdentifierOccurrence where
  toJSON IdentifierOccurrence {..} =
    A.object $
    [("sort", A.toJSON sort)] ++
    [("description", A.toJSON description)] ++
    [("internalId", A.toJSON internalId) | isJust internalId] ++
    [("isBinder", A.toJSON isBinder) | isBinder] ++
    [("instanceResolution", A.toJSON instanceResolution) | isJust instanceResolution] ++
    [("idOccType", A.toJSON idOccType) | isJust idOccType]
instance A.ToJSON IdentifierOccurrenceSort
instance A.ToJSON TypeComponent where
  toJSON = A.genericToJSON omitNothingOptions
instance A.ToJSON Type where
  toJSON = A.genericToJSON omitNothingOptions
instance A.ToJSON ExpressionInfo where
  toJSON = A.genericToJSON omitNothingOptions
instance A.ToJSON DirTree
instance A.ToJSON DefinitionSite where
  toJSON = A.genericToJSON omitNothingOptions
instance A.ToJSON IdentifierSrcSpan
instance A.ToJSON (IVM.Interval (Int, Int)) where
  toJSON (IVM.IntervalCO a b) = intervalToValue a b
  toJSON (IVM.ClosedInterval a b) = intervalToValue a b
  toJSON (IVM.OpenInterval a b) = intervalToValue a b
  toJSON (IVM.IntervalOC a b) = intervalToValue a b

intervalToValue :: (Int, Int) -> (Int, Int) -> A.Value
intervalToValue (l1, c1) (l2, c2) =
  A.object
    [ ("start", A.object [("line", A.toJSON l1), ("column", A.toJSON c1)])
    , ("end", A.object [("line", A.toJSON l2), ("column", A.toJSON c2)])
    ]

data SourceCodePreprocessing
  = AfterPreprocessing
  | BeforePreprocessing
  deriving (Show, Eq)

data Log
  = StdOut
  | ToFile FilePath
  deriving (Show, Eq)