module Input.Item(
Sig(..), Ctx(..), Ty(..), prettySig,
Item(..), itemName,
Target(..), targetExpandURL, TargetId(..),
splitIPackage, splitIModule,
hseToSig, hseToItem
) 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.IString
import Prelude
import Data.Aeson.Types
import qualified Data.Text as T
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 String
| IModule String
| IName String
| ISignature (Sig IString)
| IAlias String [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) = rnf x
rnf (ISignature x) = rnf x
rnf (IAlias a b c) = rnf (a,b,c)
rnf (IInstance a) = rnf a
itemName :: Item -> Maybe String
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)]
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)] -> [(String, [(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 String) -> [a] -> [(String, [a])]
splitUsing f = repeatedly $ \(x:xs) ->
let (a,b) = break (isJust . f) xs
in ((fromMaybe "" $ f x, x:a), b)
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) []
ty (TyInfix an a b c) = ty $ let ap = TyApp an in TyCon an b `ap` a `ap` c
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 <$> hseToSig ty) : map (IName . fromName) names
hseToItem (TypeDecl _ (fromDeclHead -> (name, bind)) rhs) = [IAlias (fromName name) (map (toIString . fromName . fromTyVarBind) bind) (toIString <$> hseToSig rhs)]
hseToItem (InstDecl an _ (fromIParen -> IRule _ _ ctx (fromInstHead -> (name, args))) _) = [IInstance $ fmap toIString $ hseToSig $ TyForall an Nothing ctx $ applyType (TyCon an name) args]
hseToItem x = map IName $ declNames x