From cf2c56c7061b7ed40fdd3b40a352ddb9c9b7371f Mon Sep 17 00:00:00 2001 From: alexwl Date: Tue, 2 Oct 2018 13:17:04 +0300 Subject: Initial commit --- src/HaskellCodeExplorer/Types.hs | 880 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 880 insertions(+) create mode 100644 src/HaskellCodeExplorer/Types.hs (limited to 'src/HaskellCodeExplorer/Types.hs') diff --git a/src/HaskellCodeExplorer/Types.hs b/src/HaskellCodeExplorer/Types.hs new file mode 100644 index 0000000..9e3667d --- /dev/null +++ b/src/HaskellCodeExplorer/Types.hs @@ -0,0 +1,880 @@ +{-# 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 + , 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(..) + , Hyperlink(..) + , Picture(..) + ) +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 = V.fromList <$> 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 str) = Html.span . Html.toHtml . T.pack $ str + toH (DocHyperlink (Hyperlink url mbTitle)) = + Html.a Html.! (Attr.href . Html.textValue . T.pack $ url) $ + Html.toHtml $ fromMaybe url mbTitle + 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 + +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) -- cgit v1.2.3