You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
135 lines
4.6 KiB
135 lines
4.6 KiB
{-# LANGUAGE CPP #-}
|
|
module Web where
|
|
|
|
import Control.Exception.Base
|
|
import Control.Monad.Reader
|
|
|
|
import qualified Data.ByteString.Lazy as Bsl
|
|
import qualified Data.Text.Encoding as T
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Text as T
|
|
|
|
import Elab.Eval (zonkIO, force)
|
|
import Elab.Monad
|
|
import Elab
|
|
|
|
import Foreign
|
|
|
|
import Presyntax.Presyntax
|
|
import Presyntax.Parser
|
|
import Presyntax.Lexer
|
|
|
|
import Syntax.Pretty
|
|
import Syntax
|
|
|
|
#ifdef ASTERIUS
|
|
import Asterius.Types
|
|
import Asterius.Aeson
|
|
#endif
|
|
|
|
parseFromString :: String -> IO (StablePtr [Statement])
|
|
parseFromString str = do
|
|
case runAlex (Bsl.fromStrict (T.encodeUtf8 inp)) parseProg of
|
|
Right e -> newStablePtr e
|
|
Left e -> throwIO (ErrorCall e)
|
|
where
|
|
inp = T.pack str
|
|
|
|
newEnvironment :: IO (StablePtr ElabEnv)
|
|
newEnvironment = newStablePtr =<< emptyEnv
|
|
|
|
typeCheckProgram :: StablePtr ElabEnv -> StablePtr [Statement] -> IO (StablePtr ElabEnv)
|
|
typeCheckProgram envP prog =
|
|
do
|
|
prog <- deRefStablePtr prog
|
|
env <- runElab (go prog) =<< deRefStablePtr envP
|
|
newStablePtr env
|
|
where
|
|
go prog = checkProgram prog ask
|
|
|
|
getTypeByName :: String -> StablePtr ElabEnv -> IO (StablePtr Value)
|
|
getTypeByName str env = do
|
|
env <- deRefStablePtr env
|
|
case Map.lookup (T.pack str) (nameMap env) of
|
|
Just nm -> newStablePtr (fst (getEnv env Map.! nm))
|
|
Nothing -> throwIO (NotInScope (Bound (T.pack str) 0))
|
|
|
|
getValueByName :: String -> StablePtr ElabEnv -> IO (StablePtr Value)
|
|
getValueByName str env = do
|
|
env <- deRefStablePtr env
|
|
case Map.lookup (T.pack str) (nameMap env) of
|
|
Just nm -> newStablePtr (snd (getEnv env Map.! nm))
|
|
Nothing -> throwIO (NotInScope (Bound (T.pack str) 0))
|
|
|
|
classifyValue :: StablePtr Value -> IO String
|
|
classifyValue val = do
|
|
t <- deRefStablePtr val
|
|
pure $ case force t of
|
|
VNe (HData pathcs _) _
|
|
| pathcs -> "data.higher"
|
|
| otherwise -> "data"
|
|
VNe (HCon _ _) _ -> "constr"
|
|
_ -> "other"
|
|
|
|
classifyValueByName :: String -> StablePtr ElabEnv -> IO String
|
|
classifyValueByName str env = do
|
|
env <- deRefStablePtr env
|
|
case Map.lookup (T.pack str) (nameMap env) of
|
|
Just nm ->
|
|
pure $ case force (snd (getEnv env Map.! nm)) of
|
|
VNe (HData pathcs _) _
|
|
| pathcs -> "constr.data.higher"
|
|
| otherwise -> "constr.data"
|
|
VNe HPCon{} _ -> "constr.higher"
|
|
VNe HCon{} _ -> "constr"
|
|
_ -> "other"
|
|
Nothing -> throwIO $ NotInScope (Bound (T.pack str) 0)
|
|
|
|
findDefinition :: String -> StablePtr ElabEnv -> IO (Maybe (Posn, Posn))
|
|
findDefinition str env = do
|
|
env <- deRefStablePtr env
|
|
case Map.lookup (T.pack str) (nameMap env) of
|
|
Just nm -> pure $ Map.lookup nm (whereBound env)
|
|
Nothing -> throwIO $ NotInScope (Bound (T.pack str) 0)
|
|
|
|
zonkAndShowType :: StablePtr Value -> IO String
|
|
zonkAndShowType val = do
|
|
val <- deRefStablePtr val
|
|
val <- zonkIO val
|
|
let str = show . prettyTm . quote $ val
|
|
pure str
|
|
|
|
freeHaskellValue :: StablePtr a -> IO ()
|
|
freeHaskellValue = freeStablePtr
|
|
|
|
#ifdef ASTERIUS
|
|
|
|
parseFromStringJs :: JSString -> IO (StablePtr [Statement])
|
|
parseFromStringJs = parseFromString . fromJSString
|
|
|
|
getTypeByNameJs :: JSString -> StablePtr ElabEnv -> IO (StablePtr Value)
|
|
getTypeByNameJs str env = getTypeByName (fromJSString str) env
|
|
|
|
getValueByNameJs :: JSString -> StablePtr ElabEnv -> IO (StablePtr Value)
|
|
getValueByNameJs str env = getValueByName (fromJSString str) env
|
|
|
|
zonkAndShowTypeJs :: StablePtr Value -> IO JSString
|
|
zonkAndShowTypeJs = fmap toJSString . zonkAndShowType
|
|
|
|
classifyValueByNameJs :: JSString -> StablePtr ElabEnv -> IO JSString
|
|
classifyValueByNameJs str env = toJSString <$> classifyValueByName (fromJSString str) env
|
|
|
|
findDefinitionJs :: JSString -> StablePtr ElabEnv -> IO JSVal
|
|
findDefinitionJs str env = jsonToJSVal <$> findDefinition (fromJSString str) env
|
|
|
|
foreign export javascript parseFromStringJs :: JSString -> IO (StablePtr [Statement])
|
|
foreign export javascript getTypeByNameJs :: JSString -> StablePtr ElabEnv -> IO (StablePtr Value)
|
|
foreign export javascript getValueByNameJs :: JSString -> StablePtr ElabEnv -> IO (StablePtr Value)
|
|
foreign export javascript classifyValueByNameJs :: JSString -> StablePtr ElabEnv -> IO JSString
|
|
foreign export javascript newEnvironment :: IO (StablePtr ElabEnv)
|
|
foreign export javascript typeCheckProgram :: StablePtr ElabEnv -> StablePtr [Statement] -> IO (StablePtr ElabEnv)
|
|
foreign export javascript zonkAndShowTypeJs :: StablePtr Value -> IO JSString
|
|
foreign export javascript freeHaskellValue :: StablePtr Value -> IO ()
|
|
foreign export javascript findDefinitionJs :: JSString -> StablePtr ElabEnv -> IO JSVal
|
|
|
|
#endif
|