Commit a7e36038c0a2c39f7d08821443eae983d555e486 - endsay

+3

-0

.gitignore less more

	1	dist
	2	dist-newstyle
	3	*~

+31

-0

endsay.cabal less more

	1	name: endsay
	2	version: 0.1.0.0
	3	-- synopsis:
	4	-- description:
	5	license: BSD3
	6	license-file: LICENSE
	7	author: Getty Ritter <gettylefou@gmail.com>
	8	maintainer: Getty Ritter <gettylefou@gmail.com>
	9	copyright: ©2016 Getty Ritter
	10	-- category:
	11	build-type: Simple
	12	cabal-version: >= 1.12
	13
	14	executable endsay
	15	hs-source-dirs: src
	16	main-is: Main.hs
	17	other-modules: Types
	18	Parse
	19	default-extensions: OverloadedStrings,
	20	ScopedTypeVariables
	21	ghc-options: -Wall
	22	build-depends: base >=4.7 && <4.9
	23	, containers
	24	, text
	25	, transformers
	26	, vector
	27	, bytestring
	28	, unordered-containers
	29	, megaparsec
	30	, semigroups
	31	default-language: Haskell2010

+8

-0

src/Main.hs less more

	1	module Main where
	2
	3	import Run
	4
	5	main :: IO ()
	6	main = do
	7	let program = "5 dup mul ="
	8	runEndsay program run >>= print

+47

-0

src/PSNum.hs less more

	1	{-# LANGUAGE RankNTypes #-}
	2
	3	module PSNum where
	4
	5	import Types
	6
	7	data PSNum
	8	= PSInt Integer
	9	\| PSReal Double
	10	deriving (Eq, Show)
	11
	12	toPSNum :: Object -> Endsay PSNum
	13	toPSNum (OInteger n) = return (PSInt n)
	14	toPSNum (OReal n) = return (PSReal n)
	15	toPSNum _ = error ".."
	16
	17	fromPSNum :: PSNum -> Object
	18	fromPSNum (PSInt n) = OInteger n
	19	fromPSNum (PSReal n) = OReal n
	20
	21	promoteNum :: (forall a. Num a => a -> a -> a) -> PSNum -> PSNum -> PSNum
	22	promoteNum op (PSInt x) (PSInt y) = PSInt (x `op` y)
	23	promoteNum op (PSInt x) (PSReal y) = PSReal (fromIntegral x `op` y)
	24	promoteNum op (PSReal x) (PSInt y) = PSReal (x `op` fromIntegral y)
	25	promoteNum op (PSReal x) (PSReal y) = PSReal (x `op` y)
	26
	27	resNum :: (forall a. (Num a, Ord a) => a -> a -> b) -> PSNum -> PSNum -> b
	28	resNum op (PSInt x) (PSInt y) = (x `op` y)
	29	resNum op (PSInt x) (PSReal y) = (fromIntegral x `op` y)
	30	resNum op (PSReal x) (PSInt y) = (x `op` fromIntegral y)
	31	resNum op (PSReal x) (PSReal y) = (x `op` y)
	32
	33	overNum :: (forall a. Num a => a -> a) -> PSNum -> PSNum
	34	overNum op (PSInt x) = PSInt (op x)
	35	overNum op (PSReal x) = PSReal (op x)
	36
	37	instance Num PSNum where
	38	(+) = promoteNum (+)
	39	(-) = promoteNum (-)
	40	() = promoteNum ()
	41	negate = overNum negate
	42	abs = overNum abs
	43	signum = overNum signum
	44	fromInteger = PSInt
	45
	46	instance Ord PSNum where
	47	compare = resNum compare

+103

-0

src/Parse.hs less more

	1	module Parse where
	2
	3	import Control.Monad (when)
	4	import Data.ByteString (ByteString)
	5	import qualified Data.ByteString as BS
	6	import Data.Char (ord)
	7	import Data.List.NonEmpty (NonEmpty(..))
	8	import Data.Text (Text)
	9	import qualified Data.Text as T
	10	import Text.Megaparsec
	11	import Text.Megaparsec.Text
	12
	13	import Types
	14
	15	-- Okay, yeah, 'tokenize' would be better, sure
	16
	17	initialParserState :: Text -> State Text
	18	initialParserState t = State
	19	{ stateInput = t
	20	, statePos = SourcePos "<file>" (unsafePos 1) (unsafePos 1) :\| []
	21	, stateTabWidth = unsafePos 8
	22	}
	23
	24	pNextParsedObject :: State Text -> Either String (ParsedObject, State Text)
	25	pNextParsedObject st = result
	26	where result = case runParser' (pWhitespace *> pParsedObject) st of
	27	(_, Left err) -> Left (show err)
	28	(s, Right v) -> Right (v, s)
	29
	30	pWhitespace :: Parser ()
	31	pWhitespace = skipMany spaceChar
	32
	33	specialChars :: String
	34	specialChars = "()<>[]{}/% \t\r\n"
	35
	36	pParsedObject :: Parser ParsedObject
	37	pParsedObject =
	38	uncurry PORadix <$> try pRadix
	39	<\|> POReal <$> pReal
	40	<\|> POInteger <$> pInteger
	41	<\|> POString <$> pString
	42	<\|> POByteString <$> pByteString
	43	<\|> POSymbol <$> pSymbol
	44	<\|> POName <$> pName
	45
	46	pSign :: Num a => Parser (a -> a)
	47	pSign = negate <$ char '-'
	48	<\|> id <$ char '+'
	49	<\|> pure id
	50
	51	pRadix :: Parser (Int, Integer)
	52	pRadix = do
	53	base <- read <$> some digitChar
	54	_ <- char '#'
	55	when (base < 2 \|\| base > 36) $
	56	fail ("Invalid base: " ++ show base)
	57	num <- some (digitForBase base)
	58	return (base, readAsBase base num)
	59
	60	readAsBase :: Num a => Int -> String -> a
	61	readAsBase _ [] = error "[unreachable]"
	62	readAsBase _ [c] = numValOf c
	63	readAsBase b (c:cs) = (numValOf c * fromIntegral b) + readAsBase b cs
	64
	65	digitForBase :: Int -> Parser Char
	66	digitForBase n = oneOf chars
	67	where chars = take n ['0'..'9'] ++
	68	take (n-1) ['A'..'Z'] ++
	69	take (n-1) ['a'..'z']
	70
	71	pReal :: Parser Double
	72	pReal = fail "unimplemented"
	73
	74	pInteger :: Parser Integer
	75	pInteger = do
	76	sign <- pSign
	77	num <- some digitChar
	78	return $ sign (read num)
	79
	80	pString :: Parser Text
	81	pString = T.pack <$> (char '(' *> go)
	82	where go =
	83	"" <$ char ')'
	84	<\|> (++) <$> some (noneOf ['(',')','\\']) <*> go -- XXX: handle rest!
	85
	86	pByteString :: Parser ByteString
	87	pByteString = char '<' > (go <$> some hexDigitChar) < char '>'
	88	where go = BS.pack . toVals
	89	toVals (x:y:xs) = (numValOf x * 16 + numValOf y) : toVals xs
	90	toVals (x:[]) = [ numValOf x * 16 ]
	91	toVals [] = []
	92
	93	numValOf :: Num b => Char -> b
	94	numValOf n
	95	\| n >= 'a' && n <= 'z' = fromIntegral (ord n) - 0x57
	96	\| n >= 'A' && n <= 'Z' = fromIntegral (ord n) - 0x37
	97	\| otherwise = fromIntegral (ord n) - 0x30
	98
	99	pSymbol :: Parser Text
	100	pSymbol = T.pack <$> (char '/' *> many (noneOf specialChars))
	101
	102	pName :: Parser Text
	103	pName = T.pack <$> some (noneOf specialChars)

+17

-0

src/Pretty.hs less more

	1	module Pretty where
	2
	3	import Data.Monoid ((<>))
	4	import qualified Data.Text as T
	5	import qualified Data.Text.IO as T
	6
	7	class PSShow t where
	8	psShow :: t -> Text
	9
	10	instance PSShow Object where
	11	psShow (OBool True) = "true"
	12	psShow (OBool False) = "false"
	13	psShow (OInteger i) = "0"
	14	psShow (OString t) = "(" <> t <> ")"
	15
	16	psPrint :: PSShow t => t -> IO ()
	17	psPrint = T.putStrLn . psShow

+118

-0

src/Run.hs less more

	1	module Run where
	2
	3	import Control.Monad ((=<<), forever)
	4	import Control.Monad.IO.Class
	5	import Control.Monad.Trans.Class (lift)
	6	import Control.Monad.Trans.Except
	7	import Control.Monad.Trans.State
	8	import Data.HashMap.Strict (HashMap)
	9	import qualified Data.HashMap.Strict as HM
	10	import Data.Monoid ((<>), Last(..))
	11	import qualified Data.Sequence as S
	12	import Data.Sequence (Seq, (<\|), ViewL(..))
	13	import Data.Text (Text)
	14
	15	import Types
	16	import Parse
	17	import PSNum
	18
	19	pop :: Endsay Object
	20	pop = Endsay $ do
	21	st <- lift get
	22	let x :< xs = S.viewl (isOpStack st)
	23	lift $ put st { isOpStack = xs }
	24	return x
	25
	26	push :: Object -> Endsay ()
	27	push o = Endsay $ lift $ modify (\ s -> s { isOpStack = o <\| isOpStack s })
	28
	29	pushObject :: ParsedObject -> Endsay ()
	30	pushObject (POInteger n) = push (OInteger n)
	31	pushObject (POReal n) = push (OReal n)
	32	pushObject (PORadix _ n) = push (OInteger n)
	33	pushObject (POString t) = push (OString t)
	34	pushObject (POByteString t) = return ()
	35	pushObject (POSymbol t) = push (OName t)
	36	pushObject (POName t) = runCommand t
	37
	38	runCommand :: Text -> Endsay ()
	39	runCommand t = do
	40	obj <- findName t
	41	case obj of
	42	Nothing -> liftIO $ putStrLn "Name not found"
	43	Just (OBuiltInOperator (BuiltIn b)) -> b
	44
	45	runEndsay :: Text -> Endsay a -> IO (Either ESErr a, InterpreterState)
	46	runEndsay t (Endsay mote) =
	47	runStateT (runExceptT mote) (initialInterpreterState t)
	48	-- runStateT (runInterp mote) (runStateT (initialInterpreterState t) (runInterp mote))
	49
	50	findName :: Text -> Endsay (Maybe Object)
	51	findName t = do
	52	InterpreterState { isDictStack = ds } <- Endsay $ lift get
	53	return $ getLast $ foldr (\ d r -> Last (HM.lookup t d) <> r) (Last Nothing) ds
	54
	55	step :: Endsay ()
	56	step = do
	57	st <- Endsay $ lift get
	58	case pNextParsedObject (isParseState st) of
	59	Left err -> Endsay $ throwE (ESErr "unable to parse another thing")
	60	Right (po, st') -> do
	61	pushObject po
	62	Endsay $ lift $ modify $ \ s -> s { isParseState = st' }
	63
	64	run :: Endsay ()
	65	run = forever step
	66
	67	initialInterpreterState :: Text -> InterpreterState
	68	initialInterpreterState t = InterpreterState
	69	{ isSource = t
	70	, isParseState = initialParserState t
	71	, isOpStack = S.empty
	72	, isDictStack = S.singleton $ basicDict
	73	, isExecStack = S.empty
	74	}
	75
	76	builtin :: Endsay () -> Object
	77	builtin = OBuiltInOperator . BuiltIn
	78
	79	basicDict :: HashMap Text Object
	80	basicDict = HM.fromList
	81	[ ("add", builtin $ do
	82	x <- toPSNum =<< pop
	83	y <- toPSNum =<< pop
	84	push (fromPSNum (x + y))
	85	)
	86	, ("sub", builtin $ do
	87	x <- toPSNum =<< pop
	88	y <- toPSNum =<< pop
	89	push (fromPSNum (x - y))
	90	)
	91	, ("mul", builtin $ do
	92	x <- toPSNum =<< pop
	93	y <- toPSNum =<< pop
	94	push (fromPSNum (x * y))
	95	)
	96	, ("lt", builtin $ do
	97	x <- toPSNum =<< pop
	98	y <- toPSNum =<< pop
	99	push (OBool (x < y))
	100	)
	101	, ("gt", builtin $ do
	102	x <- toPSNum =<< pop
	103	y <- toPSNum =<< pop
	104	push (OBool (x > y))
	105	)
	106	, ("dup", builtin $ do
	107	x <- pop
	108	push x
	109	push x
	110	)
	111	, ("exch", builtin $ do
	112	x <- pop
	113	y <- pop
	114	push x
	115	push x
	116	)
	117	, ("=", builtin $ pop >>= liftIO . print)
	118	]

+1

-0

src/Stdlib.hs less more

1

module Stdlib where

+70

-0

src/Types.hs less more

	1	{-# LANGUAGE GeneralizedNewtypeDeriving #-}
	2	{-# LANGUAGE RankNTypes #-}
	3
	4	module Types where
	5
	6	import Control.Monad.Trans.Except (ExceptT)
	7	import Control.Monad.Trans.State (StateT)
	8	import Control.Monad.IO.Class (MonadIO)
	9	import Data.ByteString (ByteString)
	10	import Data.HashMap.Strict (HashMap)
	11	import Data.Sequence (Seq)
	12	import Data.Text (Text)
	13	import Data.Vector (Vector)
	14	import qualified Text.Megaparsec as MP
	15
	16	data InterpreterState = InterpreterState
	17	{ isSource :: Text
	18	, isParseState :: MP.State Text
	19	, isOpStack :: Seq Object
	20	, isDictStack :: Seq (HashMap Text Object)
	21	, isExecStack :: Seq Object
	22	} deriving (Show)
	23
	24	data BuiltIn = BuiltIn (Endsay ())
	25
	26	instance Show BuiltIn where show _ = "BuiltIn { ... }"
	27
	28	type Fragment = Vector Object
	29
	30	data ESErr = ESErr String deriving (Eq, Show)
	31
	32	newtype Endsay a =
	33	Endsay { runInterp :: ExceptT ESErr (StateT InterpreterState IO) a }
	34	deriving (Functor, Applicative, Monad, MonadIO)
	35
	36	data Object
	37	= OBool Bool
	38	\| OFontId ()
	39	\| OInteger Integer
	40	\| OMark ()
	41	\| OName Text
	42	\| ONull
	43	\| OOperator ()
	44	\| OBuiltInOperator BuiltIn
	45	\| OReal Double
	46	\| OArray (Vector Object)
	47	\| ODictionary (HashMap Text Object)
	48	\| OFile ()
	49	-- \| OGState ()
	50	-- \| OPackedArray ()
	51	\| OSave ()
	52	\| OString Text
	53	deriving (Show)
	54
	55	data ParsedObject
	56	= POInteger Integer
	57	\| POReal Double
	58	\| PORadix Int Integer
	59	\| POString Text
	60	\| POByteString ByteString
	61	\| POSymbol Text
	62	\| POName Text
	63	deriving (Eq, Show)
	64
	65	data SourceLiteral = SourceLiteral
	66	{ slObject :: ParsedObject
	67	, slLine :: Int
	68	, slColumn :: Int
	69	, slText :: Text
	70	} deriving (Eq, Show)