Commit 4df71e21723926cba6b27ba8dea04426a9962dd2 - virgil

+0

-144

~~Language/Vergilius/AST.hs~~ less more

1		{-# LANGUAGE OverloadedStrings #-}
2
3		module Language.Vergilius.AST where
4
5		import Data.ByteString.Lazy (ByteString)
6		import Data.HashMap.Strict (HashMap, fromList)
7		import qualified Data.HashMap.Strict as HM
8		import Data.Scientific (Scientific)
9		import Data.Text (Text)
10		import Data.Vector (Vector)
11		import qualified Data.Vector as V
12
13		type Ident = ByteString
14
15		-- \| A top-level declaration.
16		data Decl
17		= Fragment ChValue
18		\| DFun FunDec
19		\| DTyp TypDec
20		deriving (Eq, Show)
21
22		type ChObject = HashMap Text ChValue
23		type ChArray = Vector ChValue
24
25		mkArray :: [ChValue] -> ChValue
26		mkArray = ChArray . V.fromList
27
28		mkObject :: [(Text, ChValue)] -> ChValue
29		mkObject = ChObject . HM.fromList
30
31		data ChValue
32		= ChObject ChObject
33		\| ChArray ChArray
34		\| ChString Text
35		\| ChNumber Scientific
36		\| ChBool Bool
37		\| ChNull
38		\| ChQuote Expr
39		deriving (Eq, Show)
40
41		data Typ
42		= TApp Typ Typ
43		\| TNamed Ident
44		\| TArrow
45		\| TUnit
46		\| TVar Ident
47		\| TFix Ident Typ
48		\| TSum [(Ident, Typ)]
49		\| TProd [(Ident, Typ)]
50		\| TTup [Typ]
51		deriving (Eq, Show)
52
53		data TypDec = TypDec
54		{ tdName :: Ident
55		, tdVars :: [Ident]
56		, tdBody :: Typ
57		} deriving (Eq, Show)
58
59		data FunDec = FunDec
60		{ fdName :: Ident
61		, fdTyp :: Maybe Typ
62		, fdCases :: [FnCase]
63		} deriving (Eq, Show)
64
65		data FnCase = FnCase
66		{ fcPat :: Pattern
67		, fcBody :: Expr
68		} deriving (Eq, Show)
69
70		data Pattern
71		= PConstr Ident Pattern
72		\| PVar Ident
73		\| PLit Literal
74		\| PTup [Pattern]
75		\| PUnderscore
76		deriving (Eq, Show)
77
78		type Env = HashMap Ident Value
79
80		data Value
81		= VConstr Ident Value
82		\| VRecord [(Ident, Value)]
83		\| VTup [Value]
84		\| VLam [FnCase] Env
85		\| VLit Literal
86		deriving (Eq, Show)
87
88		data Expr
89		= ELit Literal
90		\| EConstr Ident
91		\| EApp Expr Expr
92		\| EVar Ident
93		\| ETup [Expr]
94		\| EList [Expr]
95		\| ERecord [(Ident, Expr)]
96		\| ELam [FnCase]
97		\| ETyped Expr Typ
98		\| EAccess Expr Ident
99		deriving (Eq, Show)
100
101		data Literal
102		= LInt Integer
103		\| LDouble Double
104		\| LString Text
105		\| LBool Bool
106		deriving (Eq, Show)
107
108		{-
109		with fact : Int -> Int
110		0 = 1
111		n = n * fact (n - 1)
112		-}
113		fact :: Decl
114		fact = DFun $ FunDec
115		{ fdName = "fact"
116		, fdTyp = Just (TApp (TApp TArrow (TNamed "Int"))
117		(TNamed "Int"))
118		, fdCases = [ FnCase { fcPat = PLit (LInt 0)
119		, fcBody = ELit (LInt 1)
120		}
121		, FnCase { fcPat = PVar "n"
122		, fcBody = EApp (EApp (EVar "mul") (EVar "n"))
123		(EApp (EVar "fact")
124		(EApp (EApp
125		(EVar "sub")
126		(EVar "n"))
127		(ELit (LInt 1))))
128		}
129		]
130		}
131
132		{-
133		foo:
134		bar: '(fact 5)
135		baz: '(fact 10)
136		-}
137		foo :: Decl
138		foo = Fragment $ ChObject $ fromList
139		[ ("foo", ChObject $ fromList
140		[ ("bar", ChQuote (EApp (EVar "fact") (ELit (LInt 5))))
141		, ("baz", ChQuote (EApp (EVar "fact") (ELit (LInt 10))))
142		]
143		)
144		]

+0

-78

~~Language/Vergilius/Eval.hs~~ less more

1		{-# LANGUAGE ParallelListComp #-}
2		{-# LANGUAGE OverloadedStrings #-}
3
4		module Language.Vergilius.Eval where
5
6		import qualified Data.Aeson as Ae
7		import Data.HashMap.Strict (HashMap)
8		import qualified Data.HashMap.Strict as HM
9
10		import Language.Vergilius.AST
11
12		evalCh :: ChValue -> Either String Ae.Value
13		evalCh (ChObject obj) = Ae.Object `fmap` mapM evalCh obj
14		evalCh (ChArray arr) = Ae.Array `fmap` mapM evalCh arr
15		evalCh (ChString t) = pure (Ae.String t)
16		evalCh (ChNumber n) = pure (Ae.Number n)
17		evalCh (ChBool b) = pure (Ae.Bool b)
18		evalCh ChNull = pure Ae.Null
19		evalCh (ChQuote _) = Left "no evaluation yet"
20
21		-- \| Match a pattern against a value
22		match :: Pattern -> Value -> Maybe [(Ident, Value)]
23		match (PConstr i p) (VConstr i' v)
24		\| i == i' = match p v
25		match (PTup ps) (VTup vs)
26		\| length ps == length vs =
27		fmap concat (sequence [ match p v \| p <- ps \| v <- vs ])
28		match (PVar i) x = return [(i, x)]
29		match (PLit l) (VLit v)
30		\| l == v = return []
31		match PUnderscore _ = return []
32		match _ _ = Nothing
33
34		eval :: Env -> Expr -> Either String Value
35		eval _ (ELit l) = return (VLit l)
36		eval _ con@(EConstr _) = do
37		let fnCase = FnCase { fcPat = PVar "x"
38		, fcBody = EApp con (EVar "x")
39		}
40		return (VLam [fnCase] HM.empty)
41		eval env (EApp (EConstr i) e) = do
42		e' <- eval env e
43		return (VConstr i e')
44		eval env (EApp f x) = do
45		VLam cs env' <- eval env f
46		arg <- eval env x
47		app env cs arg
48		eval env (EVar v) = case HM.lookup v env of
49		Just x -> Right x
50		Nothing -> Left ("Unbound variable: " ++ show v)
51		eval env (ETup es) = do
52		vs <- mapM (eval env) es
53		return (VTup vs)
54		eval env (EList es) = do
55		vs <- mapM (eval env) es
56		return (foldr (\ x xs -> VConstr "Cons" (VTup [x, xs]))
57		(VConstr "Nil" (VTup []))
58		vs)
59		eval env (ERecord rs) = do
60		vs <- mapM (eval env . snd) rs
61		return (VRecord [ (i, v) \| i <- map fst rs \| v <- vs ])
62		eval env (ELam cs) = return (VLam cs env)
63		eval env (ETyped e _) = eval env e
64		eval env (EAccess e i) = do
65		VRecord r <- eval env e
66		case lookup i r of
67		Just v -> return v
68		Nothing -> Left ("Bad lookup: field " ++ show i ++
69		" in " ++ show r)
70
71		extend :: Env -> [(Ident, Value)] -> Env
72		extend = foldr (uncurry HM.insert)
73
74		app :: Env -> [FnCase] -> Value -> Either String Value
75		app _ [] _ = Left "Non-exhaustive cases"
76		app env (c:cs) arg = case match (fcPat c) arg of
77		Just bindings -> eval (extend env bindings) (fcBody c)
78		Nothing -> app env cs arg

+0

-105

~~Language/Vergilius/Lexer.x~~ less more

1		{
2		{-# OPTIONS -w #-}
3		{-# LANGUAGE OverloadedStrings #-}
4
5		module Language.Vergilius.Lexer where
6
7		import Control.Monad (liftM)
8		import Data.Text (Text)
9		import qualified Data.Text as T
10
11		import Prelude hiding (lex)
12		}
13
14		%wrapper "monadUserState"
15
16		$digit = 0-9
17		$alpha = [A-Za-z]
18
19		tokens :-
20		$white+ ;
21		"#".* ;
22
23		$digit+ { lex (TkInt . read . T.unpack) }
24		\"[^\"]*\" { lex strLiteral } -- this is for syntax highlighting -> "
25
26		true { lex' (TkKw KwTrue) }
27		false { lex' (TkKw KwFalse) }
28		null { lex' (TkKw KwNull) }
29
30		\{ { lex' TkLCurl }
31		\} { lex' TkRCurl }
32		\[ { lex' TkLBrac }
33		\] { lex' TkRBrac }
34
35		{
36		data Token = Token AlexPosn TkType deriving (Eq, Show)
37
38		data KwType
39		= KwTrue
40		\| KwFalse
41		\| KwNull
42		deriving (Eq, Show)
43
44		data TkType
45		= TkInt Integer
46		\| TkStr Text
47		\| TkKw KwType
48		\| TkLCurl
49		\| TkRCurl
50		\| TkLBrac
51		\| TkRBrac
52		\| TkEOF
53		deriving (Eq, Show)
54
55		strLiteral :: Text -> TkType
56		strLiteral = TkStr . T.drop 1 . T.dropEnd 1
57
58		data AlexUserState = AlexUserState
59		{ filePath :: FilePath
60		} deriving (Eq, Show)
61
62		alexInitUserState :: AlexUserState
63		alexInitUserState = AlexUserState "<unknown>"
64
65		getFilePath :: Alex FilePath
66		getFilePath = liftM filePath alexGetUserState
67
68		setFilePath :: FilePath -> Alex ()
69		setFilePath = alexSetUserState . AlexUserState
70
71		alexMonadScan' :: Alex Token
72		alexMonadScan' = do
73		inp <- alexGetInput
74		sc <- alexGetStartCode
75		case alexScan inp sc of
76		AlexEOF -> alexEOF
77		AlexError (p, _, _, s) ->
78		alexError' p ("lexical error at character '" ++ take 1 s ++ "'")
79		AlexSkip inp' len -> do
80		alexSetInput inp'
81		alexMonadScan'
82		AlexToken inp' len action -> do
83		alexSetInput inp'
84		action (ignorePendingBytes inp) len
85
86		alexError' :: AlexPosn -> String -> Alex a
87		alexError' (AlexPn _ l c) msg = do
88		fp <- getFilePath
89		alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
90
91		alexEOF :: Alex Token
92		alexEOF = do
93		(p,_,_,_) <- alexGetInput
94		return (Token p TkEOF)
95
96
97		lex :: (Text -> TkType) -> AlexAction Token
98		lex f = \(p,_,_,s) i -> return (Token p (f (T.pack (take i s))))
99
100		lex' :: TkType -> AlexAction Token
101		lex' = lex . const
102
103		runAlex' :: Alex a -> FilePath -> String -> Either String a
104		runAlex' mote fp input = runAlex input (setFilePath fp >> mote)
105		}

+0

-36

~~Language/Vergilius/Parse.hs~~ less more

1		{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2
3		module Language.Vergilius.Parse where
4
5		import Data.Char (isAlpha, isDigit)
6
7		data ParseState = ParseState
8		{ indentLevel :: Int
9		} deriving (Eq, Show)
10
11		type Parser a = ParsecT Text ParseState Identity a
12
13		pInt :: Parser Literal
14		pInt = (LInt . read) <$> takeWhile1 digit
15
16		pLiteral :: Parser Expr
17		pLiteral = ELit <$> pInt
18
19		pIChar :: Parser [Char]
20		pIChar = satisfy (getAny (mconcat (map (Any .) tests)))
21		where tests = [ (== '_')
22		, isAlpha
23		, isDigit
24		]
25
26		pConstr :: Parser Text
27		pConstr = do
28		c <- upper
29		cs <- many pIChar
30		return (T.cons c (T.pack cs))
31
32		pIdent :: Parser Text
33		pIdent = do
34		c <- lower
35		cs <- many pIChar
36		return (T.cons c (T.pack cs))

+0

-73

~~Language/Vergilius/Parser.y~~ less more

1		{
2		{-# LANGUAGE OverloadedStrings #-}
3
4		module Language.Vergilius.Parser where
5
6		import Language.Vergilius.AST
7		import Language.Vergilius.Lexer
8
9		}
10
11		%name parse
12		%tokentype { Token }
13		%monad { Alex }
14		%lexer { lexwrap } { Token _ TkEOF }
15		%error { happyError }
16
17		%token
18		'{' { Token _ TkLCurl }
19		'}' { Token _ TkRCurl }
20		'[' { Token _ TkLBrac }
21		']' { Token _ TkRBrac }
22
23		true { Token _ (TkKw KwTrue) }
24		false { Token _ (TkKw KwFalse) }
25		null { Token _ (TkKw KwNull) }
26
27		int { Token _ (TkInt $$) }
28		str { Token _ (TkStr $$) }
29
30		%%
31
32		tlexpr
33		: '[' list { mkArray $2 }
34		\| '{' dict { mkObject $2 }
35
36		expr
37		: tlexpr { $1 }
38		\| int { ChNumber (fromIntegral $1) }
39		\| str { ChString $1 }
40		\| true { ChBool True }
41		\| false { ChBool False}
42		\| null { ChNull }
43
44		list
45		: ']' { [] }
46		\| expr list { $1 : $2 }
47
48		dict
49		: '}' { [] }
50		\| str expr dict { ($1, $2) : $3 }
51
52		{
53
54		-- info :: a -> Alex (Info a)
55		-- info x = do
56		-- (AlexPn _ ln cl,_,_,_) <- alexGetInput
57		-- fp <- getFilePath
58		-- return $ Info { node = x
59		-- , srcLine = ln
60		-- , srcCol = cl
61		-- , srcFile = fp
62		-- }
63
64		lexwrap :: (Token -> Alex a) -> Alex a
65		lexwrap = (alexMonadScan' >>=)
66
67		happyError :: Token -> Alex a
68		happyError (Token p t) =
69		alexError' p ("parse error at token " ++ show t)
70
71		parseFile :: FilePath -> String -> Either String ChValue
72		parseFile = runAlex' parse
73		}

+0

-9

~~Language/Vergilius/Pretty.hs~~ less more

1		module Language.Vergilius.Pretty where
2
3		import Data.Monoid ((<>))
4		import Text.PrettyPrint.HughesPJ.Class
5		import Language.Vergilius.AST
6
7		instance Pretty ChValue where
8		pPrint (ChObject obj) = braces $ text "..."
9		pPrint

+0

-14

~~Language/Vergilius/Types.hs~~ less more

1		module Language.Vergilius.Types where
2
3		import Language.Cherenkov.AST
4
5		type TEnv = HashMap Ident Typ
6
7		inferType :: TEnv -> Expr -> ()
8		inferType _ (ELit (LInt _)) = TNamed "Int"
9		inferType _ (ELit (LDouble _)) = TNamed "Double"
10		inferType _ (ELit (LString _)) = TNamed "String"
11		inferType _ (ELit (LBool _)) = TNamed "Bool"
12		inferType e (ETup ts) = VTup (map (inferType e ts))
13		inferType e (EList ls) = undefined
14		inferType e (EVar v) = undefined

+0

-71

~~Language/Vergilius.hs~~ less more

1		module Language.Vergilius
2		( -- * Vergil Parsers
3		decode
4		, eitherDecode
5		, decodeStrict
6		, eitherDecodeStrict
7		-- * Re-Exported Aeson Types
8		-- ** Core JSON Types
9		, Aeson.Value(..)
10		, Aeson.Array
11		, Aeson.Object
12		-- ** Type Conversion
13		, Aeson.FromJSON(..)
14		, Aeson.ToJSON(..)
15		, Aeson.Result(..)
16		, Aeson.fromJSON
17		-- ** Inspecting Values
18		, Aeson.withObject
19		, Aeson.withText
20		, Aeson.withArray
21		, Aeson.withScientific
22		, Aeson.withBool
23		-- ** Accessors
24		, (Aeson..:)
25		, (Aeson..:?)
26		, (Aeson..:!)
27		, (Aeson..!=)
28		) where
29
30		import Data.Aeson (FromJSON, Result(..), fromJSON)
31		import qualified Data.Aeson as Aeson
32		import qualified Data.ByteString as BSE
33		import Data.ByteString.Lazy (ByteString)
34		import qualified Data.ByteString.Lazy.Char8 as BS
35		import Language.Vergilius.AST (ChValue)
36		import Language.Vergilius.Eval
37		import Language.Vergilius.Lexer
38		import Language.Vergilius.Parser
39
40		parseVirgil :: ByteString -> Either String ChValue
41		parseVirgil = runAlex' parse "<input>" . BS.unpack
42
43		-- \| Deserialize and execute a Virgil program. If parsing fails,
44		-- or if type-checking fails, or if the execution of the Virgil
45		-- program otherwise fails at runtime, then this function will
46		-- return 'Nothing'.
47		--
48		-- Note that Virgil rules out recursive programs, so executing a
49		-- Virgil program won't loop forever---but it may still take
50		-- a fair amount longer than parsing the equivalent JSON!
51		decode :: FromJSON a => ByteString -> Maybe a
52		decode bs = case eitherDecode bs of
53		Error err -> Nothing
54		Success val -> pure val
55
56		-- \| Deserialize and execute a Virgil program. If parsing fails,
57		-- or if type-checking fails, or if the execution of the Virgil
58		-- program otherwise fails at runtime, then this function will
59		-- return an approrpriately informative error message.
60		eitherDecode :: FromJSON a => ByteString -> Result a
61		eitherDecode bs = case parseVirgil bs of
62		Left err -> Error err
63		Right ch -> case evalCh ch of
64		Left err -> Error err
65		Right v -> fromJSON v
66
67		decodeStrict :: FromJSON a => BSE.ByteString -> Maybe a
68		decodeStrict = decode . BS.fromStrict
69
70		eitherDecodeStrict :: FromJSON a => BSE.ByteString -> Result a
71		eitherDecodeStrict = eitherDecode . BS.fromStrict

+144

-0

Language/Virgil/AST.hs less more

	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Language.Virgil.AST where
	4
	5	import Data.ByteString.Lazy (ByteString)
	6	import Data.HashMap.Strict (HashMap, fromList)
	7	import qualified Data.HashMap.Strict as HM
	8	import Data.Scientific (Scientific)
	9	import Data.Text (Text)
	10	import Data.Vector (Vector)
	11	import qualified Data.Vector as V
	12
	13	type Ident = ByteString
	14
	15	-- \| A top-level declaration.
	16	data Decl
	17	= Fragment ChValue
	18	\| DFun FunDec
	19	\| DTyp TypDec
	20	deriving (Eq, Show)
	21
	22	type ChObject = HashMap Text ChValue
	23	type ChArray = Vector ChValue
	24
	25	mkArray :: [ChValue] -> ChValue
	26	mkArray = ChArray . V.fromList
	27
	28	mkObject :: [(Text, ChValue)] -> ChValue
	29	mkObject = ChObject . HM.fromList
	30
	31	data ChValue
	32	= ChObject ChObject
	33	\| ChArray ChArray
	34	\| ChString Text
	35	\| ChNumber Scientific
	36	\| ChBool Bool
	37	\| ChNull
	38	\| ChQuote Expr
	39	deriving (Eq, Show)
	40
	41	data Typ
	42	= TApp Typ Typ
	43	\| TNamed Ident
	44	\| TArrow
	45	\| TUnit
	46	\| TVar Ident
	47	\| TFix Ident Typ
	48	\| TSum [(Ident, Typ)]
	49	\| TProd [(Ident, Typ)]
	50	\| TTup [Typ]
	51	deriving (Eq, Show)
	52
	53	data TypDec = TypDec
	54	{ tdName :: Ident
	55	, tdVars :: [Ident]
	56	, tdBody :: Typ
	57	} deriving (Eq, Show)
	58
	59	data FunDec = FunDec
	60	{ fdName :: Ident
	61	, fdTyp :: Maybe Typ
	62	, fdCases :: [FnCase]
	63	} deriving (Eq, Show)
	64
	65	data FnCase = FnCase
	66	{ fcPat :: Pattern
	67	, fcBody :: Expr
	68	} deriving (Eq, Show)
	69
	70	data Pattern
	71	= PConstr Ident Pattern
	72	\| PVar Ident
	73	\| PLit Literal
	74	\| PTup [Pattern]
	75	\| PUnderscore
	76	deriving (Eq, Show)
	77
	78	type Env = HashMap Ident Value
	79
	80	data Value
	81	= VConstr Ident Value
	82	\| VRecord [(Ident, Value)]
	83	\| VTup [Value]
	84	\| VLam [FnCase] Env
	85	\| VLit Literal
	86	deriving (Eq, Show)
	87
	88	data Expr
	89	= ELit Literal
	90	\| EConstr Ident
	91	\| EApp Expr Expr
	92	\| EVar Ident
	93	\| ETup [Expr]
	94	\| EList [Expr]
	95	\| ERecord [(Ident, Expr)]
	96	\| ELam [FnCase]
	97	\| ETyped Expr Typ
	98	\| EAccess Expr Ident
	99	deriving (Eq, Show)
	100
	101	data Literal
	102	= LInt Integer
	103	\| LDouble Double
	104	\| LString Text
	105	\| LBool Bool
	106	deriving (Eq, Show)
	107
	108	{-
	109	with fact : Int -> Int
	110	0 = 1
	111	n = n * fact (n - 1)
	112	-}
	113	fact :: Decl
	114	fact = DFun $ FunDec
	115	{ fdName = "fact"
	116	, fdTyp = Just (TApp (TApp TArrow (TNamed "Int"))
	117	(TNamed "Int"))
	118	, fdCases = [ FnCase { fcPat = PLit (LInt 0)
	119	, fcBody = ELit (LInt 1)
	120	}
	121	, FnCase { fcPat = PVar "n"
	122	, fcBody = EApp (EApp (EVar "mul") (EVar "n"))
	123	(EApp (EVar "fact")
	124	(EApp (EApp
	125	(EVar "sub")
	126	(EVar "n"))
	127	(ELit (LInt 1))))
	128	}
	129	]
	130	}
	131
	132	{-
	133	foo:
	134	bar: '(fact 5)
	135	baz: '(fact 10)
	136	-}
	137	foo :: Decl
	138	foo = Fragment $ ChObject $ fromList
	139	[ ("foo", ChObject $ fromList
	140	[ ("bar", ChQuote (EApp (EVar "fact") (ELit (LInt 5))))
	141	, ("baz", ChQuote (EApp (EVar "fact") (ELit (LInt 10))))
	142	]
	143	)
	144	]

+78

-0

Language/Virgil/Eval.hs less more

	1	{-# LANGUAGE ParallelListComp #-}
	2	{-# LANGUAGE OverloadedStrings #-}
	3
	4	module Language.Virgil.Eval where
	5
	6	import qualified Data.Aeson as Ae
	7	import Data.HashMap.Strict (HashMap)
	8	import qualified Data.HashMap.Strict as HM
	9
	10	import Language.Virgil.AST
	11
	12	evalCh :: ChValue -> Either String Ae.Value
	13	evalCh (ChObject obj) = Ae.Object `fmap` mapM evalCh obj
	14	evalCh (ChArray arr) = Ae.Array `fmap` mapM evalCh arr
	15	evalCh (ChString t) = pure (Ae.String t)
	16	evalCh (ChNumber n) = pure (Ae.Number n)
	17	evalCh (ChBool b) = pure (Ae.Bool b)
	18	evalCh ChNull = pure Ae.Null
	19	evalCh (ChQuote _) = Left "no evaluation yet"
	20
	21	-- \| Match a pattern against a value
	22	match :: Pattern -> Value -> Maybe [(Ident, Value)]
	23	match (PConstr i p) (VConstr i' v)
	24	\| i == i' = match p v
	25	match (PTup ps) (VTup vs)
	26	\| length ps == length vs =
	27	fmap concat (sequence [ match p v \| p <- ps \| v <- vs ])
	28	match (PVar i) x = return [(i, x)]
	29	match (PLit l) (VLit v)
	30	\| l == v = return []
	31	match PUnderscore _ = return []
	32	match _ _ = Nothing
	33
	34	eval :: Env -> Expr -> Either String Value
	35	eval _ (ELit l) = return (VLit l)
	36	eval _ con@(EConstr _) = do
	37	let fnCase = FnCase { fcPat = PVar "x"
	38	, fcBody = EApp con (EVar "x")
	39	}
	40	return (VLam [fnCase] HM.empty)
	41	eval env (EApp (EConstr i) e) = do
	42	e' <- eval env e
	43	return (VConstr i e')
	44	eval env (EApp f x) = do
	45	VLam cs env' <- eval env f
	46	arg <- eval env x
	47	app env cs arg
	48	eval env (EVar v) = case HM.lookup v env of
	49	Just x -> Right x
	50	Nothing -> Left ("Unbound variable: " ++ show v)
	51	eval env (ETup es) = do
	52	vs <- mapM (eval env) es
	53	return (VTup vs)
	54	eval env (EList es) = do
	55	vs <- mapM (eval env) es
	56	return (foldr (\ x xs -> VConstr "Cons" (VTup [x, xs]))
	57	(VConstr "Nil" (VTup []))
	58	vs)
	59	eval env (ERecord rs) = do
	60	vs <- mapM (eval env . snd) rs
	61	return (VRecord [ (i, v) \| i <- map fst rs \| v <- vs ])
	62	eval env (ELam cs) = return (VLam cs env)
	63	eval env (ETyped e _) = eval env e
	64	eval env (EAccess e i) = do
	65	VRecord r <- eval env e
	66	case lookup i r of
	67	Just v -> return v
	68	Nothing -> Left ("Bad lookup: field " ++ show i ++
	69	" in " ++ show r)
	70
	71	extend :: Env -> [(Ident, Value)] -> Env
	72	extend = foldr (uncurry HM.insert)
	73
	74	app :: Env -> [FnCase] -> Value -> Either String Value
	75	app _ [] _ = Left "Non-exhaustive cases"
	76	app env (c:cs) arg = case match (fcPat c) arg of
	77	Just bindings -> eval (extend env bindings) (fcBody c)
	78	Nothing -> app env cs arg

+105

-0

Language/Virgil/Lexer.x less more

	1	{
	2	{-# OPTIONS -w #-}
	3	{-# LANGUAGE OverloadedStrings #-}
	4
	5	module Language.Virgil.Lexer where
	6
	7	import Control.Monad (liftM)
	8	import Data.Text (Text)
	9	import qualified Data.Text as T
	10
	11	import Prelude hiding (lex)
	12	}
	13
	14	%wrapper "monadUserState"
	15
	16	$digit = 0-9
	17	$alpha = [A-Za-z]
	18
	19	tokens :-
	20	$white+ ;
	21	"#".* ;
	22
	23	$digit+ { lex (TkInt . read . T.unpack) }
	24	\"[^\"]*\" { lex strLiteral } -- this is for syntax highlighting -> "
	25
	26	true { lex' (TkKw KwTrue) }
	27	false { lex' (TkKw KwFalse) }
	28	null { lex' (TkKw KwNull) }
	29
	30	\{ { lex' TkLCurl }
	31	\} { lex' TkRCurl }
	32	\[ { lex' TkLBrac }
	33	\] { lex' TkRBrac }
	34
	35	{
	36	data Token = Token AlexPosn TkType deriving (Eq, Show)
	37
	38	data KwType
	39	= KwTrue
	40	\| KwFalse
	41	\| KwNull
	42	deriving (Eq, Show)
	43
	44	data TkType
	45	= TkInt Integer
	46	\| TkStr Text
	47	\| TkKw KwType
	48	\| TkLCurl
	49	\| TkRCurl
	50	\| TkLBrac
	51	\| TkRBrac
	52	\| TkEOF
	53	deriving (Eq, Show)
	54
	55	strLiteral :: Text -> TkType
	56	strLiteral = TkStr . T.drop 1 . T.dropEnd 1
	57
	58	data AlexUserState = AlexUserState
	59	{ filePath :: FilePath
	60	} deriving (Eq, Show)
	61
	62	alexInitUserState :: AlexUserState
	63	alexInitUserState = AlexUserState "<unknown>"
	64
	65	getFilePath :: Alex FilePath
	66	getFilePath = liftM filePath alexGetUserState
	67
	68	setFilePath :: FilePath -> Alex ()
	69	setFilePath = alexSetUserState . AlexUserState
	70
	71	alexMonadScan' :: Alex Token
	72	alexMonadScan' = do
	73	inp <- alexGetInput
	74	sc <- alexGetStartCode
	75	case alexScan inp sc of
	76	AlexEOF -> alexEOF
	77	AlexError (p, _, _, s) ->
	78	alexError' p ("lexical error at character '" ++ take 1 s ++ "'")
	79	AlexSkip inp' len -> do
	80	alexSetInput inp'
	81	alexMonadScan'
	82	AlexToken inp' len action -> do
	83	alexSetInput inp'
	84	action (ignorePendingBytes inp) len
	85
	86	alexError' :: AlexPosn -> String -> Alex a
	87	alexError' (AlexPn _ l c) msg = do
	88	fp <- getFilePath
	89	alexError (fp ++ ":" ++ show l ++ ":" ++ show c ++ ": " ++ msg)
	90
	91	alexEOF :: Alex Token
	92	alexEOF = do
	93	(p,_,_,_) <- alexGetInput
	94	return (Token p TkEOF)
	95
	96
	97	lex :: (Text -> TkType) -> AlexAction Token
	98	lex f = \(p,_,_,s) i -> return (Token p (f (T.pack (take i s))))
	99
	100	lex' :: TkType -> AlexAction Token
	101	lex' = lex . const
	102
	103	runAlex' :: Alex a -> FilePath -> String -> Either String a
	104	runAlex' mote fp input = runAlex input (setFilePath fp >> mote)
	105	}

+73

-0

Language/Virgil/Parser.y less more

	1	{
	2	{-# LANGUAGE OverloadedStrings #-}
	3
	4	module Language.Virgil.Parser where
	5
	6	import Language.Virgil.AST
	7	import Language.Virgil.Lexer
	8
	9	}
	10
	11	%name parse
	12	%tokentype { Token }
	13	%monad { Alex }
	14	%lexer { lexwrap } { Token _ TkEOF }
	15	%error { happyError }
	16
	17	%token
	18	'{' { Token _ TkLCurl }
	19	'}' { Token _ TkRCurl }
	20	'[' { Token _ TkLBrac }
	21	']' { Token _ TkRBrac }
	22
	23	true { Token _ (TkKw KwTrue) }
	24	false { Token _ (TkKw KwFalse) }
	25	null { Token _ (TkKw KwNull) }
	26
	27	int { Token _ (TkInt $$) }
	28	str { Token _ (TkStr $$) }
	29
	30	%%
	31
	32	tlexpr
	33	: '[' list { mkArray $2 }
	34	\| '{' dict { mkObject $2 }
	35
	36	expr
	37	: tlexpr { $1 }
	38	\| int { ChNumber (fromIntegral $1) }
	39	\| str { ChString $1 }
	40	\| true { ChBool True }
	41	\| false { ChBool False}
	42	\| null { ChNull }
	43
	44	list
	45	: ']' { [] }
	46	\| expr list { $1 : $2 }
	47
	48	dict
	49	: '}' { [] }
	50	\| str expr dict { ($1, $2) : $3 }
	51
	52	{
	53
	54	-- info :: a -> Alex (Info a)
	55	-- info x = do
	56	-- (AlexPn _ ln cl,_,_,_) <- alexGetInput
	57	-- fp <- getFilePath
	58	-- return $ Info { node = x
	59	-- , srcLine = ln
	60	-- , srcCol = cl
	61	-- , srcFile = fp
	62	-- }
	63
	64	lexwrap :: (Token -> Alex a) -> Alex a
	65	lexwrap = (alexMonadScan' >>=)
	66
	67	happyError :: Token -> Alex a
	68	happyError (Token p t) =
	69	alexError' p ("parse error at token " ++ show t)
	70
	71	parseFile :: FilePath -> String -> Either String ChValue
	72	parseFile = runAlex' parse
	73	}

+9

-0

Language/Virgil/Pretty.hs less more

	1	module Language.Virgil.Pretty where
	2
	3	import Data.Monoid ((<>))
	4	import Text.PrettyPrint.HughesPJ.Class
	5	import Language.Virgil.AST
	6
	7	instance Pretty ChValue where
	8	pPrint (ChObject obj) = braces $ text "..."
	9	pPrint

+14

-0

Language/Virgil/Types.hs less more

	1	module Language.Virgil.Types where
	2
	3	import Language.Cherenkov.AST
	4
	5	type TEnv = HashMap Ident Typ
	6
	7	inferType :: TEnv -> Expr -> ()
	8	inferType _ (ELit (LInt _)) = TNamed "Int"
	9	inferType _ (ELit (LDouble _)) = TNamed "Double"
	10	inferType _ (ELit (LString _)) = TNamed "String"
	11	inferType _ (ELit (LBool _)) = TNamed "Bool"
	12	inferType e (ETup ts) = VTup (map (inferType e ts))
	13	inferType e (EList ls) = undefined
	14	inferType e (EVar v) = undefined

+71

-0

Language/Virgil.hs less more

	1	module Language.Virgil
	2	( -- * Virgil Parsers
	3	decode
	4	, eitherDecode
	5	, decodeStrict
	6	, eitherDecodeStrict
	7	-- * Re-Exported Aeson Types
	8	-- ** Core JSON Types
	9	, Aeson.Value(..)
	10	, Aeson.Array
	11	, Aeson.Object
	12	-- ** Type Conversion
	13	, Aeson.FromJSON(..)
	14	, Aeson.ToJSON(..)
	15	, Aeson.Result(..)
	16	, Aeson.fromJSON
	17	-- ** Inspecting Values
	18	, Aeson.withObject
	19	, Aeson.withText
	20	, Aeson.withArray
	21	, Aeson.withScientific
	22	, Aeson.withBool
	23	-- ** Accessors
	24	, (Aeson..:)
	25	, (Aeson..:?)
	26	, (Aeson..:!)
	27	, (Aeson..!=)
	28	) where
	29
	30	import Data.Aeson (FromJSON, Result(..), fromJSON)
	31	import qualified Data.Aeson as Aeson
	32	import qualified Data.ByteString as BSE
	33	import Data.ByteString.Lazy (ByteString)
	34	import qualified Data.ByteString.Lazy.Char8 as BS
	35	import Language.Virgil.AST (ChValue)
	36	import Language.Virgil.Eval
	37	import Language.Virgil.Lexer
	38	import Language.Virgil.Parser
	39
	40	parseVirgil :: ByteString -> Either String ChValue
	41	parseVirgil = runAlex' parse "<input>" . BS.unpack
	42
	43	-- \| Deserialize and execute a Virgil program. If parsing fails,
	44	-- or if type-checking fails, or if the execution of the Virgil
	45	-- program otherwise fails at runtime, then this function will
	46	-- return 'Nothing'.
	47	--
	48	-- Note that Virgil rules out recursive programs, so executing a
	49	-- Virgil program won't loop forever---but it may still take
	50	-- a fair amount longer than parsing the equivalent JSON!
	51	decode :: FromJSON a => ByteString -> Maybe a
	52	decode bs = case eitherDecode bs of
	53	Error err -> Nothing
	54	Success val -> pure val
	55
	56	-- \| Deserialize and execute a Virgil program. If parsing fails,
	57	-- or if type-checking fails, or if the execution of the Virgil
	58	-- program otherwise fails at runtime, then this function will
	59	-- return an approrpriately informative error message.
	60	eitherDecode :: FromJSON a => ByteString -> Result a
	61	eitherDecode bs = case parseVirgil bs of
	62	Left err -> Error err
	63	Right ch -> case evalCh ch of
	64	Left err -> Error err
	65	Right v -> fromJSON v
	66
	67	decodeStrict :: FromJSON a => BSE.ByteString -> Maybe a
	68	decodeStrict = decode . BS.fromStrict
	69
	70	eitherDecodeStrict :: FromJSON a => BSE.ByteString -> Result a
	71	eitherDecodeStrict = eitherDecode . BS.fromStrict

+0

-32

~~vergilius.cabal~~ less more

1		name: vergilius
2		version: 0.1.0.0
3		-- synopsis:
4		-- description:
5		license: BSD3
6		license-file: LICENSE
7		author: Getty Ritter
8		maintainer: gdritter@galois.com
9		-- copyright:
10		category: Language
11		build-type: Simple
12		-- extra-source-files:
13		cabal-version: >=1.10
14
15		library
16		exposed-modules: Language.Vergilius,
17		Language.Vergilius.Lexer,
18		Language.Vergilius.Parser,
19		Language.Vergilius.Eval
20		-- other-modules:
21		-- other-extensions:
22		build-depends: base >=4.7 && <4.9,
23		aeson,
24		array,
25		bytestring,
26		unordered-containers,
27		scientific,
28		text,
29		vector,
30		pretty
31		build-tools: alex
32		default-language: Haskell2010⏎

+30

-0

virgil.cabal less more

	1	name: virgil
	2	version: 0.1.0.0
	3	synopsis: An executable configuration language.
	4	-- description:
	5	license: BSD3
	6	license-file: LICENSE
	7	author: Getty Ritter
	8	maintainer: gettyritter@gmail.com
	9	copyright: 2016 Getty Ritter
	10	category: Language
	11	build-type: Simple
	12	cabal-version: >=1.10
	13
	14	library
	15	exposed-modules: Language.Virgil
	16	other-modules: Language.Virgil.Lexer,
	17	Language.Virgil.Parser,
	18	Language.Virgil.Eval,
	19	Language.Virgil.AST
	20	build-depends: base >=4.7 && <4.9,
	21	aeson,
	22	array,
	23	bytestring,
	24	unordered-containers,
	25	scientific,
	26	text,
	27	vector,
	28	pretty
	29	build-tools: alex
	30	default-language: Haskell2010⏎