{-# LANGUAGE RecordWildCards #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TupleSections #-}

{-# LANGUAGE RankNTypes #-}

module Language.PureScript.Docs.Types

( module Language.PureScript.Docs.Types

, module ReExports

)

where

import Control.Arrow (first, (***))

import Control.Applicative ((<$>), (<*>))

import Data.Functor ((<$))

import Data.Char

import Data.Maybe (mapMaybe)

import Data.Version

import Data.Aeson ((.=))

import qualified Data.Aeson as A

import Data.Aeson.BetterErrors

import Text.ParserCombinators.ReadP (readP_to_S)

import Data.Text (Text)

import Data.ByteString.Lazy (ByteString)

import qualified Data.Text as T

import Web.Bower.PackageMeta hiding (Version)

import qualified Language.PureScript as P

import Language.PureScript.Docs.RenderedCode as ReExports

(RenderedCode, asRenderedCode,

ContainingModule(..), asContainingModule,

RenderedCodeElement(..), asRenderedCodeElement)

data Package a = Package

{ pkgMeta :: PackageMeta

, pkgVersion :: Version

, pkgVersionTag :: String

, pkgModules :: [RenderedModule]

, pkgBookmarks :: [Bookmark]

, pkgResolvedDependencies :: [(PackageName, Version)]

, pkgGithub :: (GithubUser, GithubRepo)

, pkgUploader :: a

}

deriving (Show, Eq, Ord)

data NotYetKnown = NotYetKnown

deriving (Show, Eq, Ord)

type UploadedPackage = Package NotYetKnown

type VerifiedPackage = Package GithubUser

verifyPackage :: GithubUser -> UploadedPackage -> VerifiedPackage

verifyPackage verifiedUser Package{..} =

Package pkgMeta

pkgVersion

pkgVersionTag

pkgModules

pkgBookmarks

pkgResolvedDependencies

pkgGithub

verifiedUser

packageName :: Package a -> PackageName

packageName = bowerName . pkgMeta

data RenderedModule = RenderedModule

{ rmName :: String

, rmComments :: Maybe String

, rmDeclarations :: [RenderedDeclaration]

}

deriving (Show, Eq, Ord)

data RenderedDeclaration = RenderedDeclaration

{ rdTitle :: String

, rdComments :: Maybe String

, rdCode :: RenderedCode

, rdSourceSpan :: Maybe P.SourceSpan

, rdChildren :: [RenderedChildDeclaration]

}

deriving (Show, Eq, Ord)

data RenderedChildDeclaration = RenderedChildDeclaration

{ rcdTitle :: String

, rcdComments :: Maybe String

, rcdCode :: RenderedCode

, rcdSourceSpan :: Maybe P.SourceSpan

, rcdType :: RenderedChildDeclarationType

}

deriving (Show, Eq, Ord)

data RenderedChildDeclarationType

= ChildInstance

| ChildDataConstructor

| ChildTypeClassMember

deriving (Show, Eq, Ord, Bounded, Enum)

childDeclTypeToString :: RenderedChildDeclarationType -> String

childDeclTypeToString = withHead toLower . drop 5 . show

where

withHead f (x:xs) = f x : xs

withHead _ [] = []

childDeclarationTypes :: [(String, RenderedChildDeclarationType)]

childDeclarationTypes =

map (\t -> (childDeclTypeToString t, t)) [minBound .. maxBound]

newtype GithubUser

= GithubUser { runGithubUser :: String }

deriving (Show, Eq, Ord)

newtype GithubRepo

= GithubRepo { runGithubRepo :: String }

deriving (Show, Eq, Ord)

data PackageError

= ErrorInPackageMeta BowerError

| InvalidVersion

| InvalidDeclarationType

| InvalidRenderedCode String

deriving (Show, Eq, Ord)

type Bookmark = InPackage (P.ModuleName, String)

data InPackage a

= Local a

| FromDep PackageName a

deriving (Show, Eq, Ord)

instance Functor InPackage where

fmap f (Local x) = Local (f x)

fmap f (FromDep pkgName x) = FromDep pkgName (f x)

takeLocal :: InPackage a -> Maybe a

takeLocal (Local a) = Just a

takeLocal _ = Nothing

takeLocals :: [InPackage a] -> [a]

takeLocals = mapMaybe takeLocal

ignorePackage :: InPackage a -> a

ignorePackage (Local x) = x

ignorePackage (FromDep _ x) = x

parseUploadedPackage :: ByteString -> Either (ParseError PackageError) UploadedPackage

parseUploadedPackage = parse asUploadedPackage

parseVerifiedPackage :: ByteString -> Either (ParseError PackageError) VerifiedPackage

parseVerifiedPackage = parse asVerifiedPackage

asPackage :: (forall e. Parse e a) -> Parse PackageError (Package a)

asPackage uploader =

Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta

<*> key "version" asVersion

<*> key "versionTag" asString

<*> key "modules" (eachInArray asRenderedModule)

<*> key "bookmarks" asBookmarks .! ErrorInPackageMeta

<*> key "resolvedDependencies" asResolvedDependencies

<*> key "github" asGithub

<*> key "uploader" uploader

asUploadedPackage :: Parse PackageError UploadedPackage

asUploadedPackage = asPackage asNotYetKnown

asNotYetKnown :: Parse e NotYetKnown

asNotYetKnown = NotYetKnown <$ asNull

instance A.FromJSON NotYetKnown where

parseJSON = toAesonParser' asNotYetKnown

asVerifiedPackage :: Parse PackageError VerifiedPackage

asVerifiedPackage = asPackage asGithubUser

asGithubUser :: Parse e GithubUser

asGithubUser = GithubUser <$> asString

instance A.FromJSON GithubUser where

parseJSON = toAesonParser' asGithubUser

instance A.FromJSON a => A.FromJSON (Package a) where

-- TODO: actual error display

parseJSON = toAesonParser (T.pack . show)

(asPackage fromAesonParser)

asVersion :: Parse PackageError Version

asVersion = withString (maybe (Left InvalidVersion) Right . parseVersion')

parseVersion' :: String -> Maybe Version

parseVersion' str =

case filter (null . snd) $ readP_to_S parseVersion str of

[(vers, "")] -> Just vers

_ -> Nothing

asRenderedModule :: Parse PackageError RenderedModule

asRenderedModule =

RenderedModule <$> key "name" asString

<*> key "comments" (perhaps asString)

<*> key "declarations" (eachInArray asDeclaration)

asDeclaration :: Parse PackageError RenderedDeclaration

asDeclaration =

RenderedDeclaration <$> key "title" asString

<*> key "comments" (perhaps asString)

<*> key "code" asRenderedCode .! InvalidRenderedCode

<*> key "sourceSpan" (perhaps asSourceSpan)

<*> key "children" (eachInArray asRenderedChildDeclaration)

asRenderedChildDeclaration :: Parse PackageError RenderedChildDeclaration

asRenderedChildDeclaration =

RenderedChildDeclaration <$> key "title" asString

<*> key "comments" (perhaps asString)

<*> key "code" asRenderedCode .! InvalidRenderedCode

<*> key "sourceSpan" (perhaps asSourceSpan)

<*> key "type" asRenderedChildDeclarationType .!! InvalidDeclarationType

where

p .!! err = p .! const err

asRenderedChildDeclarationType :: Parse PackageError RenderedChildDeclarationType

asRenderedChildDeclarationType =

withString (maybe (Left InvalidDeclarationType) Right .

flip lookup childDeclarationTypes)

asSourcePos :: Parse e P.SourcePos

asSourcePos = P.SourcePos <$> nth 0 asIntegral

<*> nth 1 asIntegral

asBookmarks :: Parse BowerError [Bookmark]

asBookmarks = eachInArray asBookmark

asBookmark :: Parse BowerError Bookmark

asBookmark =

build <$> key "package" (perhaps (withString parsePackageName))

<*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)

<*> nth 1 asString)

where

build Nothing = Local

build (Just pn) = FromDep pn

asResolvedDependencies :: Parse PackageError [(PackageName, Version)]

asResolvedDependencies =

eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName . T.unpack) asVersion

where

mapLeft f (Left x) = Left (f x)

mapLeft _ (Right x) = Right x

asGithub :: Parse e (GithubUser, GithubRepo)

asGithub = (,) <$> nth 0 (GithubUser <$> asString)

<*> nth 1 (GithubRepo <$> asString)

asSourceSpan :: Parse e P.SourceSpan

asSourceSpan = P.SourceSpan <$> key "name" asString

<*> key "start" asSourcePos

<*> key "end" asSourcePos

instance A.ToJSON a => A.ToJSON (Package a) where

toJSON Package{..} =

A.object $

[ "packageMeta" .= pkgMeta

, "version" .= showVersion pkgVersion

, "versionTag" .= pkgVersionTag

, "modules" .= pkgModules

, "bookmarks" .= map (fmap (first P.runModuleName)) pkgBookmarks

, "resolvedDependencies" .= assocListToJSON (T.pack . runPackageName)

(T.pack . showVersion)

pkgResolvedDependencies

, "github" .= pkgGithub

, "uploader" .= pkgUploader

]

instance A.ToJSON NotYetKnown where

toJSON _ = A.Null

instance A.ToJSON RenderedModule where

toJSON RenderedModule{..} =

A.object [ "name" .= rmName

, "comments" .= rmComments

, "declarations" .= rmDeclarations

]

instance A.ToJSON RenderedDeclaration where

toJSON RenderedDeclaration{..} =

A.object [ "title" .= rdTitle

, "comments" .= rdComments

, "code" .= rdCode

, "sourceSpan" .= rdSourceSpan

, "children" .= rdChildren

]

instance A.ToJSON RenderedChildDeclaration where

toJSON RenderedChildDeclaration{..} =

A.object [ "title" .= rcdTitle

, "comments" .= rcdComments

, "code" .= rcdCode

, "sourceSpan" .= rcdSourceSpan

, "type" .= rcdType

]

instance A.ToJSON RenderedChildDeclarationType where

toJSON = A.toJSON . childDeclTypeToString

instance A.ToJSON GithubUser where

toJSON = A.toJSON . runGithubUser

instance A.ToJSON GithubRepo where

toJSON = A.toJSON . runGithubRepo

-- | Given a function for turning association list keys into JSON object keys,

assocListToJSON :: (a -> Text) -> (b -> Text) -> [(a, b)] -> A.Value

assocListToJSON f g xs = A.object (map (uncurry (.=) . (f *** g)) xs)

instance A.ToJSON a => A.ToJSON (InPackage a) where

toJSON x =

case x of

Local y -> withPackage (Nothing :: Maybe ()) y

FromDep pn y -> withPackage (Just pn) y

where

withPackage :: (A.ToJSON p, A.ToJSON x) => p -> x -> A.Value

withPackage p y =

A.object [ "package" .= p

, "item" .= y

]