diff options
| -rw-r--r-- | src/HaskellCodeExplorer/Types.hs | 837 |
1 files changed, 433 insertions, 404 deletions
diff --git a/src/HaskellCodeExplorer/Types.hs b/src/HaskellCodeExplorer/Types.hs index 1bd9b25..4c3d5c7 100644 --- a/src/HaskellCodeExplorer/Types.hs +++ b/src/HaskellCodeExplorer/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -16,70 +15,79 @@ 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 +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 + { id :: PackageId , moduleMap :: HM.HashMap HaskellModulePath modInfo - , moduleNameMap :: HM.HashMap HaskellModuleName (HM.HashMap ComponentId HaskellModulePath) - , directoryTree :: DirTree + , 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) + , externalIdOccMap :: HM.HashMap ExternalId (S.Set IdentifierSrcSpan) -- ^ All occurrences of each external identifier in the package - } deriving (Show, Eq, Generic, Data) + } + deriving (Show, Eq, Generic, Data) data PackageId = PackageId - { name :: T.Text + { name :: T.Text , version :: Data.Version.Version - } deriving (Show, Eq, Ord, Generic, Data) + } + deriving (Show, Eq, Ord, Generic, Data) packageIdToText :: PackageId -> T.Text packageIdToText (PackageId name version) = @@ -90,11 +98,12 @@ packageName = (name :: (PackageId -> T.Text)) . (id :: PackageInfo a -> PackageId) data IdentifierSrcSpan = IdentifierSrcSpan - { modulePath :: HaskellModulePath - , line :: Int + { modulePath :: HaskellModulePath + , line :: Int , startColumn :: Int - , endColumn :: Int - } deriving (Show, Eq, Ord, Generic, Data) + , endColumn :: Int + } + deriving (Show, Eq, Ord, Generic, Data) data DirTree = Dir { name :: FilePath @@ -119,10 +128,10 @@ data ComponentType deriving (Show, Eq, Generic, Data) isLibrary :: ComponentType -> Bool -isLibrary Lib = True +isLibrary Lib = True isLibrary (SubLib _) = True -isLibrary (FLib _) = True -isLibrary _ = False +isLibrary (FLib _) = True +isLibrary _ = False packageInfoBinaryFileName :: FilePath packageInfoBinaryFileName = "packageInfo" @@ -138,22 +147,23 @@ defaultOutputDirectoryName = ".haskell-code-explorer" -------------------------------------------------------------------------------- data Trie k v = Trie - { values :: S.Set v + { values :: S.Set v , children :: HM.HashMap k (Trie k v) - } deriving (Show, Eq, Generic, Data) + } + deriving (Show, Eq, Generic, Data) emptyTrie :: Trie k v emptyTrie = Trie S.empty HM.empty -insertToTrie :: - (Hashable k, Eq k, Ord v) +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) = +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) @@ -161,49 +171,50 @@ insertToTrie f word@(first:rest) val (Trie vals children) = 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) = +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] +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 + { id :: HaskellModulePath + , name :: HaskellModuleName + , source :: V.Vector T.Text -- ^ Source code of the module - , transformation :: SourceCodeTransformation - , exprInfoMap :: ExpressionInfoMap + , transformation :: SourceCodeTransformation + , exprInfoMap :: ExpressionInfoMap -- ^ Type of each expression in the module - , idOccMap :: IdentifierOccurrenceMap + , idOccMap :: IdentifierOccurrenceMap -- ^ All occurrences of each identifier in the module - , idInfoMap :: IdentifierInfoMap + , idInfoMap :: IdentifierInfoMap -- ^ Information about each identifier in the module - , declarations :: [Declaration] + , declarations :: [Declaration] , definitionSiteMap :: DefinitionSiteMap -- ^ Definition site of each top-level value, type, and type class instance - , externalIds :: [ExternalIdentifierInfo] - } deriving (Show, Eq, Generic, Data) + , 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 + { values :: HM.HashMap OccName DefinitionSite + , types :: HM.HashMap OccName DefinitionSite , instances :: HM.HashMap T.Text DefinitionSite - } deriving (Show, Eq, Generic, Data) + } + deriving (Show, Eq, Generic, Data) data DefinitionSite = DefinitionSite - { location :: LocationInfo + { location :: LocationInfo , documentation :: Maybe HTML - } deriving (Show, Eq, Generic, Data) + } + deriving (Show, Eq, Generic, Data) type HTML = T.Text @@ -213,37 +224,36 @@ newtype OccName = OccName -- | 'CompactModuleInfo' contains a subset of fields of 'ModuleInfo'. data CompactModuleInfo = CompactModuleInfo - { id :: HaskellModulePath - , name :: HaskellModuleName - , exprInfoMap :: ExpressionInfoMap + { id :: HaskellModulePath + , name :: HaskellModuleName + , exprInfoMap :: ExpressionInfoMap , definitionSiteMap :: DefinitionSiteMap - , source :: V.Vector T.Text - } deriving (Show, Eq, Generic, Data) + , 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 - } +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 - } +toCompactModuleInfo ModuleInfo {..} = CompactModuleInfo + { id = id + , name = name + , exprInfoMap = exprInfoMap + , definitionSiteMap = definitionSiteMap + , source = source + } newtype HaskellModuleName = HaskellModuleName { getHaskellModuleName :: T.Text @@ -259,18 +269,19 @@ newtype HaskellFilePath = HaskellFilePath -- | Haskell identifier (value or type) data IdentifierInfo = IdentifierInfo - { sort :: NameSort - , occName :: OccName + { 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) + , 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 @@ -314,37 +325,37 @@ newtype ExternalIdentifierInfo = ExternalIdentifierInfo 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 + 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)) + EQ -> compare (internalId (i1 :: IdentifierInfo)) + (internalId (i2 :: IdentifierInfo)) data ExpressionInfo = ExpressionInfo { description :: T.Text - , exprType :: Maybe Type - } deriving (Show, Eq, Generic, Data) + , exprType :: Maybe Type + } + deriving (Show, Eq, Generic, Data) -- | Occurrence of an identifier in a source code data IdentifierOccurrence = IdentifierOccurrence - { internalId :: Maybe InternalId + { internalId :: Maybe InternalId , internalIdFromRenamedSource :: Maybe InternalId - , isBinder :: Bool - , instanceResolution :: Maybe InstanceResolution - , idOccType :: Maybe Type + , 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) + , typeArguments :: Maybe [Type] + , description :: T.Text + , sort :: IdentifierOccurrenceSort + } + deriving (Show, Eq, Ord, Generic, Data) data IdentifierOccurrenceSort = ValueId @@ -353,10 +364,11 @@ data IdentifierOccurrenceSort deriving (Show, Eq, Ord, Generic, Data) data Type = Type - { components :: [TypeComponent] + { components :: [TypeComponent] , componentsExpanded :: Maybe [TypeComponent] -- ^ Components of a type with all type synonyms expanded - } deriving (Show, Eq, Ord, Generic, Data) + } + deriving (Show, Eq, Ord, Generic, Data) data TypeComponent = Text T.Text @@ -379,62 +391,63 @@ data InstanceResolution = deriving (Show,Eq,Ord,Generic,Data) data SourceCodeTransformation = SourceCodeTransformation - { totalLines :: Int - , filePath :: HaskellModulePath + { totalLines :: Int + , filePath :: HaskellModulePath , linePragmas :: S.Set LinePragma - , fileIndex :: HM.HashMap HaskellFilePath (S.Set FileLocation) + , 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) + } + deriving (Show, Eq, Generic, Data) -- | Location of a file included by a preprocessor data FileLocation = FileLocation { lineStart :: Int - , lineEnd :: Int - , offset :: Int + , lineEnd :: Int + , offset :: Int -- ^ (line number in a preprocessed file) - (line number in an original file) + 1 - } deriving (Show, Eq, Generic, Data) + } + deriving (Show, Eq, Generic, Data) -- | Line pragma inserted by a preprocessor data LinePragma = LinePragma - { filePath :: HaskellFilePath + { 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 + , 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 + 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 + { sort :: DeclarationSort + , name :: T.Text + , declType :: Maybe Type , isExported :: Bool , lineNumber :: Int - } deriving (Show, Eq, Ord, Generic, Data) + } + deriving (Show, Eq, Ord, Generic, Data) data DeclarationSort = TyClD @@ -477,10 +490,9 @@ 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" + gunfold k z c = case constrIndex c of + 1 -> k (z IVM.fromList) + _ -> error "gunfold" dataTypeOf _ = intervalMapDataType -- dataCast2 = gcast2 @@ -503,10 +515,8 @@ instance (Serialize k, Serialize v, Ord k) => put = put . IVM.toAscList get = IVM.fromAscList <$> Data.Serialize.get instance Ord LinePragma where - compare p1 p2 = - compare - (lineNumberPreprocessed (p1 :: LinePragma)) - (lineNumberPreprocessed (p2 :: LinePragma)) + 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 @@ -517,7 +527,7 @@ instance Serialize InternalId instance Serialize ExternalId instance Serialize ExternalIdentifierInfo where put (ExternalIdentifierInfo info) = put info - get = ExternalIdentifierInfo <$>(get :: Get IdentifierInfo) + get = ExternalIdentifierInfo <$> (get :: Get IdentifierInfo) instance Serialize InstanceResolution instance Serialize OccName instance Serialize IdDetails @@ -594,224 +604,244 @@ instance (NFData k, Ord k, NFData v, Ord v, Hashable k) => NFData (Trie k v) omitNothingOptions :: Options -omitNothingOptions = defaultOptions {omitNothingFields = True} +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) - ] + 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)] + 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.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 + 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 +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 + :: 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) + 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 + 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 @@ -832,15 +862,13 @@ instance A.ToJSON ExternalId where 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 (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 @@ -860,13 +888,15 @@ instance A.ToJSON LocationInfo where 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] + 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 @@ -879,17 +909,16 @@ 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.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 + 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)]) - ] +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 |