path: root/src/HaskellCodeExplorer/Types.hs

{-# LANGUAGE OverloadedStrings #-}
{-# 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
                                                , 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(..)
                                                , Hyperlink(..)
                                                , ModLink(..)
                                                , Picture(..)
                                                , Table(..)
                                                , TableCell(..)
                                                , TableRow(..)
                                                )
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 (PackageInfo { id = PackageId name _ }) = name

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 (IdentifierInfo { demangledOccName = d1, internalId = i1 })) (ExternalIdentifierInfo (IdentifierInfo { demangledOccName = d2, internalId = i2 }))
    = case compare (T.length d1) (T.length d2) of
      GT -> GT
      LT -> LT
      EQ -> case compare d1 d2 of
        GT -> GT
        LT -> LT
        EQ -> compare i1 i2

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 (IdentifierOccurrence {..}) ->
                     addPositionAttrs
                       $      Html.span
                       Html.! Attr.class_ "identifier"
                       Html.! Attr.id
                                ( Html.textValue
                                . maybe "" getInternalId
                                $ internalIdFromRenamedSource
                                )
                       Html.! Html.dataAttribute
                                "occurrence"
                                ( Html.textValue
                                $ occurrenceLocationToText lineNumber start end
                                )
                       Html.! Html.dataAttribute
                                "identifier"
                                (Html.textValue $ maybe "" getInternalId $ internalId
                                )
                       $      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
  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)

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)