Commit b64f354c9c152d74645c8c922e90bf02c2eccf37 - virgil

+30

-0

LICENSE less more

	1	Copyright (c) 2015, Getty Ritter
	2
	3	All rights reserved.
	4
	5	Redistribution and use in source and binary forms, with or without
	6	modification, are permitted provided that the following conditions are met:
	7
	8	* Redistributions of source code must retain the above copyright
	9	notice, this list of conditions and the following disclaimer.
	10
	11	* Redistributions in binary form must reproduce the above
	12	copyright notice, this list of conditions and the following
	13	disclaimer in the documentation and/or other materials provided
	14	with the distribution.
	15
	16	* Neither the name of Getty Ritter nor the names of other
	17	contributors may be used to endorse or promote products derived
	18	from this software without specific prior written permission.
	19
	20	THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	21	"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	22	LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
	23	A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
	24	OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
	25	SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
	26	LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
	27	DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
	28	THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
	29	(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
	30	OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+135

-0

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

+67

-0

Language/Vergilius/Eval.hs less more

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

+36

-0

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))

+14

-0

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

+7

-0

Language/Vergilius.hs less more

	1	module Language.Cherenkov where
	2
	3	import Data.Aeson
	4	import Data.ByteString.Lazy (ByteString)
	5
	6	decode :: FromJSON a => ByteString -> Maybe a
	7	eitherDecode :: FromJSON a => ByteString -> Either String a

+2

-0

Setup.hs less more

	1	import Distribution.Simple
	2	main = defaultMain

+21

-0

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:
	17	-- other-modules:
	18	-- other-extensions:
	19	build-depends: base >=4.7 && <4.8
	20	-- hs-source-dirs:
	21	default-language: Haskell2010⏎