{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveFunctor, ViewPatterns #-}
{-# LANGUAGE RecordWildCards, OverloadedStrings, PatternGuards, ScopedTypeVariables #-}
module Input.Item(
Sig(..), Ctx(..), Ty(..), prettySig,
Item(..), itemName,
Target(..), targetExpandURL, TargetId(..),
splitIPackage, splitIModule,
hseToSig, hseToItem, item_test
) where
import Numeric
import Control.Applicative
import Data.Tuple.Extra
import Language.Haskell.Exts
import Data.Char
import Data.List.Extra
import Data.Maybe
import Data.Ix
import Data.Binary
import Foreign.Storable
import Control.DeepSeq
import Data.Data
import General.Util
import General.Str
import General.IString
import Prelude
import qualified Data.Aeson as J
import Data.Aeson.Types
import qualified Data.Text as T
import Test.QuickCheck
data Sig n = Sig {sigCtx :: [Ctx n], sigTy :: [Ty n]} deriving (Show,Eq,Ord,Typeable,Data,Functor)
data Ctx n = Ctx n n deriving (Show,Eq,Ord,Typeable,Data,Functor)
data Ty n = TCon n [Ty n] | TVar n [Ty n] deriving (Show,Eq,Ord,Typeable,Data,Functor)
instance NFData n => NFData (Sig n) where rnf (Sig x y) = rnf x `seq` rnf y
instance NFData n => NFData (Ctx n) where rnf (Ctx x y) = rnf x `seq` rnf y
instance NFData n => NFData (Ty n) where
rnf (TCon x y) = rnf x `seq` rnf y
rnf (TVar x y) = rnf x `seq` rnf y
instance Binary n => Binary (Sig n) where
put (Sig a b) = put a >> put b
get = liftA2 Sig get get
instance Binary n => Binary (Ctx n) where
put (Ctx a b) = put a >> put b
get = liftA2 Ctx get get
instance Binary n => Binary (Ty n) where
put (TCon x y) = put (0 :: Word8) >> put x >> put y
put (TVar x y) = put (1 :: Word8) >> put x >> put y
get = do i :: Word8 <- get; liftA2 (case i of 0 -> TCon; 1 -> TVar) get get
prettySig :: Sig String -> String
prettySig Sig{..} =
(if length ctx > 1 then "(" ++ ctx ++ ") => "
else if null ctx then "" else ctx ++ " => ") ++
intercalate " -> " (map f sigTy)
where
ctx = intercalate ", " [a ++ " " ++ b | Ctx a b <- sigCtx]
f (TVar x xs) = f $ TCon x xs
f (TCon x []) = x
f (TCon x xs) = "(" ++ unwords (x : map f xs) ++ ")"
data Item
= IPackage PkgName
| IModule ModName
| IName Str
| ISignature (Sig IString)
| IAlias Str [IString] (Sig IString)
| IInstance (Sig IString)
deriving (Show,Eq,Ord,Typeable,Data)
instance NFData Item where
rnf (IPackage x) = rnf x
rnf (IModule x) = rnf x
rnf (IName x) = x `seq` ()
rnf (ISignature x) = rnf x
rnf (IAlias a b c) = rnf (a,b,c)
rnf (IInstance a) = rnf a
itemName :: Item -> Maybe Str
itemName (IPackage x) = Just x
itemName (IModule x) = Just x
itemName (IName x) = Just x
itemName (ISignature _) = Nothing
itemName (IAlias x _ _) = Just x
itemName (IInstance _) = Nothing
newtype TargetId = TargetId Word32 deriving (Eq,Ord,Storable,NFData,Ix,Typeable)
instance Show TargetId where
show (TargetId x) = showHex x ""
data Target = Target
{targetURL :: URL
,targetPackage :: Maybe (String, URL)
,targetModule :: Maybe (String, URL)
,targetType :: String
,targetItem :: String
,targetDocs :: String
} deriving (Show,Eq,Ord)
instance NFData Target where
rnf (Target a b c d e f) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f
instance ToJSON Target where
toJSON (Target a b c d e f) = object [
("url" :: T.Text, toJSON a),
("package" :: T.Text, maybeNamedURL b),
("module" :: T.Text, maybeNamedURL c),
("type" :: T.Text, toJSON d),
("item" :: T.Text, toJSON e),
("docs" :: T.Text, toJSON f)
]
where
maybeNamedURL m = maybe emptyObject namedURL m
namedURL (name, url) = object [("name" :: T.Text, toJSON name), ("url" :: T.Text, toJSON url)]
instance FromJSON Target where
parseJSON = withObject "Target" $ \o ->
Target <$> o .: ("url" :: T.Text)
<*> o `namedUrl` ("package" :: T.Text)
<*> o `namedUrl` ("module" :: T.Text)
<*> o .: ("type" :: T.Text)
<*> o .: ("item" :: T.Text)
<*> o .: ("docs" :: T.Text)
where namedUrl o' n = do
mObj <- o' .: n
if null mObj then return Nothing
else do
pkName <- mObj .: ("name" :: T.Text)
pkUrl <- mObj .: ("url" :: T.Text)
return $ Just (pkName, pkUrl)
instance Arbitrary Target where
arbitrary = Target <$> a
<*> mNurl
<*> mNurl
<*> a
<*> a
<*> a
where a = arbitrary
mNurl = do
oneof [return Nothing
, Just <$> liftA2 (,) a a]
targetExpandURL :: Target -> Target
targetExpandURL t@Target{..} = t{targetURL = url, targetModule = second (const mod) <$> targetModule}
where
pkg = maybe "" snd targetPackage
mod = maybe pkg (plus pkg . snd) targetModule
url = plus mod targetURL
plus a b | b == "" = ""
| ':':_ <- dropWhile isAsciiLower b = b
| otherwise = a ++ b
splitIPackage, splitIModule :: [(a, Item)] -> [(Str, [(a, Item)])]
splitIPackage = splitUsing $ \x -> case snd x of IPackage x -> Just x; _ -> Nothing
splitIModule = splitUsing $ \x -> case snd x of IModule x -> Just x; _ -> Nothing
splitUsing :: (a -> Maybe Str) -> [a] -> [(Str, [a])]
splitUsing f = repeatedly $ \(x:xs) ->
let (a,b) = break (isJust . f) xs
in ((fromMaybe mempty $ f x, x:a), b)
item_test :: IO ()
item_test = testing "Input.Item.Target JSON (encode . decode = id) " $ do
quickCheck $ \(t :: Target) -> case J.eitherDecode $ J.encode t of
(Left e ) -> False
(Right t') -> t == t'
hseToSig :: Type a -> Sig String
hseToSig = tyForall
where
tyForall (TyParen _ x) = tyForall x
tyForall (TyForall _ _ c t) | Sig cs ts <- tyForall t =
Sig (maybe [] (concatMap ctx . fromContext) c ++ cs) ts
tyForall x = Sig [] $ tyFun x
tyFun (TyParen _ x) = tyFun x
tyFun (TyFun _ a b) = ty a : tyFun b
tyFun x = [ty x]
ty (TyForall _ _ _ x) = TCon "\\/" [ty x]
ty x@TyFun{} = TCon "->" $ tyFun x
ty (TyTuple an box ts) = TCon (fromQName $ Special an $ TupleCon an box $ length ts - 1) (map ty ts)
ty (TyList _ x) = TCon "[]" [ty x]
ty (TyParArray _ x) = TCon "[::]" [ty x]
ty (TyApp _ x y) = case ty x of
TCon a b -> TCon a (b ++ [ty y])
TVar a b -> TVar a (b ++ [ty y])
ty (TyVar _ x) = TVar (fromName x) []
ty (TyCon _ x) = TCon (fromQName x) []
#if !defined(MIN_VERSION_haskell_src_exts) || MIN_VERSION_haskell_src_exts(1,20,0)
ty (TyInfix an a (UnpromotedName _ b) c) = ty $ let ap = TyApp an in TyCon an b `ap` a `ap` c
#else
ty (TyInfix an a b c) = ty $ let ap = TyApp an in TyCon an b `ap` a `ap` c
#endif
ty (TyKind _ x _) = ty x
ty (TyBang _ _ _ x) = ty x
ty (TyParen _ x) = ty x
ty _ = TVar "_" []
ctx (ParenA _ x) = ctx x
ctx (InfixA an a con b) = ctx $ ClassA an con [a,b]
ctx (ClassA _ con (TyVar _ var:_)) = [Ctx (fromQName con) (fromName var)]
ctx _ = []
hseToItem :: Decl a -> [Item]
hseToItem (TypeSig _ names ty) = ISignature (toIString . strPack <$> hseToSig ty) : map (IName . strPack . fromName) names
hseToItem (TypeDecl _ (fromDeclHead -> (name, bind)) rhs) = [IAlias (strPack $ fromName name) (map (toIString . strPack . fromName . fromTyVarBind) bind) (toIString . strPack <$> hseToSig rhs)]
hseToItem (InstDecl an _ (fromIParen -> IRule _ _ ctx (fromInstHead -> (name, args))) _) = [IInstance $ fmap (toIString . strPack) $ hseToSig $ TyForall an Nothing ctx $ applyType (TyCon an name) args]
hseToItem x = map (IName . strPack) $ declNames x