├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── default.nix ├── project.nix ├── rowling.cabal ├── src └── Language │ ├── Rowling.hs │ └── Rowling │ ├── Common.hs │ ├── Definitions.hs │ ├── Definitions │ ├── Expressions.hs │ ├── Types.hs │ └── Values.hs │ ├── Evaluator.hs │ ├── Evaluator │ ├── Builtins.hs │ └── Evaluator.hs │ ├── Parser.hs │ └── TypeCheck │ ├── Builtins.hs │ └── TypeChecker.hs └── test ├── Language └── Rowling │ ├── EvaluatorSpec.hs │ ├── ParserSpec.hs │ ├── TypeCheckerSpec.hs │ ├── TypeLibSpec.hs │ └── ValuesSpec.hs ├── Spec.hs └── SpecHelper.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | cabal.sandbox.config 3 | dist 4 | **/.#* 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Allen Nelson 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Rowling 2 | 3 | #### A simple expression language with static typing and row types. 4 | 5 | Rowling has static types and type inferrence via a modified version of Hindley-Milner. It supports algebraic types a la Haskell, as well as row types (record types). Rowling's row types are particularly well-suited to JSON structures; for example, the JSON blob `{foo: 1, bar: "hello", baz: [2, 3]}` could be considered to have the row type `(foo: Int, bar: String, baz: [Int])`. In fact, rowling can operate on JSON structures "out of the box". Rowling has powerful pattern-matching. 6 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "ghc7101" }: 2 | nixpkgs.pkgs.haskell.packages.${compiler}.callPackage ./project.nix { } 3 | -------------------------------------------------------------------------------- /project.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, base, classy-prelude, containers 2 | , context-stack, data-default, error-list, hspec 3 | , hspec-expectations, mtl, parsec, scientific, stdenv, text 4 | , text-render, unordered-containers 5 | }: 6 | mkDerivation { 7 | pname = "rowling"; 8 | version = "0.1.0.1"; 9 | src = ./.; 10 | buildDepends = [ 11 | aeson base classy-prelude containers context-stack data-default 12 | error-list mtl parsec scientific text text-render 13 | unordered-containers 14 | ]; 15 | testDepends = [ 16 | aeson base classy-prelude containers context-stack data-default 17 | error-list hspec hspec-expectations mtl parsec scientific text 18 | text-render unordered-containers 19 | ]; 20 | homepage = "http://github.com/thinkpad20/rowling"; 21 | description = "A simple, easily embeddable pure-functional language with static typing and row polymorphism"; 22 | license = stdenv.lib.licenses.mit; 23 | } 24 | -------------------------------------------------------------------------------- /rowling.cabal: -------------------------------------------------------------------------------- 1 | name: rowling 2 | version: 0.1.0.1 3 | synopsis: A simple, easily embeddable pure-functional language with static 4 | typing and row polymorphism. 5 | -- description: 6 | homepage: http://github.com/thinkpad20/rowling 7 | license: MIT 8 | license-file: LICENSE 9 | author: Allen Nelson 10 | maintainer: ithinkican@gmail.com 11 | -- copyright: 12 | category: Language 13 | build-type: Simple 14 | -- extra-source-files: 15 | cabal-version: >=1.10 16 | 17 | library 18 | hs-source-dirs: src 19 | exposed-modules: Language.Rowling.Definitions 20 | , Language.Rowling.Evaluator 21 | , Language.Rowling.Parser 22 | , Language.Rowling.Definitions.Expressions 23 | , Language.Rowling.Definitions.Types 24 | , Language.Rowling.Definitions.Values 25 | , Language.Rowling.Evaluator.Builtins 26 | , Language.Rowling.Evaluator.Evaluator 27 | , Language.Rowling.TypeCheck.Builtins 28 | , Language.Rowling.TypeCheck.TypeChecker 29 | other-extensions: NoImplicitPrelude 30 | , OverloadedStrings 31 | , OverloadedLists 32 | , LambdaCase 33 | , TypeFamilies 34 | , FlexibleInstances 35 | , TypeSynonymInstances 36 | , RecordWildCards 37 | , FlexibleContexts 38 | , NoMonomorphismRestriction 39 | , BangPatterns 40 | , MultiParamTypeClasses 41 | , FunctionalDependencies 42 | build-depends: base >=4.7 && <5 43 | , containers 44 | , unordered-containers 45 | , classy-prelude 46 | , parsec 47 | , mtl 48 | , context-stack 49 | , data-default 50 | , text 51 | , aeson 52 | , scientific 53 | , error-list 54 | , text-render 55 | default-language: Haskell2010 56 | 57 | 58 | Test-Suite spec 59 | Type: exitcode-stdio-1.0 60 | Default-Language: Haskell2010 61 | Hs-Source-Dirs: src 62 | , test 63 | -- Ghc-Options: -Wall 64 | Main-Is: Spec.hs 65 | Build-Depends: base >=4.7 && <5 66 | , containers >=0.5 && <0.6 67 | , unordered-containers 68 | , classy-prelude 69 | , parsec 70 | , mtl 71 | , hspec 72 | , context-stack 73 | , data-default 74 | , text 75 | , hspec-expectations 76 | , aeson 77 | , scientific 78 | , error-list 79 | , text-render 80 | -------------------------------------------------------------------------------- /src/Language/Rowling.hs: -------------------------------------------------------------------------------- 1 | module Language.Rowling ( 2 | module Language.Rowling.Definitions, 3 | module Language.Rowling.Evaluator, 4 | module Language.Rowling.Parser, 5 | module Language.Rowling.Common) where 6 | 7 | import Langauge.Rowling.Definitions 8 | import Langauge.Rowling.Evaluator 9 | import Langauge.Rowling.Parser 10 | import Langauge.Rowling.Common 11 | -------------------------------------------------------------------------------- /src/Language/Rowling/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE NoMonomorphismRestriction #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE ViewPatterns #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | module Language.Rowling.Common ( 11 | module ClassyPrelude, 12 | module Control.Applicative, 13 | module Control.Exception.ErrorList, 14 | module Control.Monad, 15 | module Control.Monad.Except, 16 | module Control.Monad.Identity, 17 | module Control.Monad.State.Strict, 18 | module Control.Monad.Reader, 19 | module Control.Monad.Trans, 20 | module Data.Char, 21 | module Data.Default, 22 | module Data.HashMap.Strict, 23 | module Data.Maybe, 24 | module GHC.Exts, 25 | module Text.Render, 26 | Name, Record, for, tuple 27 | ) where 28 | 29 | import ClassyPrelude hiding (assert, asList, find, for, keys) 30 | import qualified Prelude as P 31 | import Control.Exception.ErrorList 32 | import Control.Monad (when) 33 | import Control.Monad.Trans (MonadIO(..), lift) 34 | import Control.Monad.Reader (ReaderT(..), MonadReader(..), (<=<), (>=>), ask, 35 | asks) 36 | import Control.Monad.State.Strict (MonadState, StateT, State, get, gets, 37 | modify, put, liftM, liftIO, runState, 38 | runStateT, execState, execStateT, evalState, 39 | evalStateT) 40 | import Control.Monad.Except (ExceptT, MonadError(..), throwError, runExceptT) 41 | import Control.Monad.Identity (Identity(..)) 42 | import Control.Applicative hiding (empty) 43 | import Data.Char (isDigit) 44 | import Data.Default 45 | import Data.HashMap.Strict (HashMap, keys, (!)) 46 | import qualified Data.HashMap.Strict as H 47 | import Data.Maybe (fromJust, isJust, isNothing) 48 | import qualified Data.Text as T 49 | import GHC.Exts (IsList) 50 | import Text.Render 51 | 52 | -- | Indicates that the text is some identifier. 53 | type Name = Text 54 | 55 | -- | A record is a lookup table with string keys. 56 | type Record = HashMap Name 57 | 58 | -- | Map reversed. 59 | for :: Functor f => f a -> (a -> b) -> f b 60 | for = flip map 61 | 62 | -- | Takes two applicative actions and returns their result as a 2-tuple. 63 | tuple :: Applicative f => f a -> f b -> f (a, b) 64 | tuple action1 action2 = (,) <$> action1 <*> action2 65 | -------------------------------------------------------------------------------- /src/Language/Rowling/Definitions.hs: -------------------------------------------------------------------------------- 1 | Vamodule Language.Rowling.Definitions ( 2 | module Language.Rowling.Definitions.Types, 3 | module Language.Rowling.Definitions.Expressions, 4 | module Language.Rowling.Definitions.Values 5 | ) where 6 | 7 | import Language.Rowling.Definitions.Types 8 | import Language.Rowling.Definitions.Expressions 9 | import Language.Rowling.Definitions.Values 10 | -------------------------------------------------------------------------------- /src/Language/Rowling/Definitions/Expressions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, OverloadedLists, LambdaCase #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | module Language.Rowling.Definitions.Expressions where 4 | 5 | import qualified Prelude as P 6 | import Data.Char (isUpper) 7 | import qualified Data.Text as T 8 | import qualified Data.Set as S 9 | import qualified Data.HashMap.Strict as H 10 | import qualified GHC.Exts as GHC 11 | 12 | import Language.Rowling.Common 13 | import Language.Rowling.Definitions.Types 14 | 15 | -- | The expression type. 16 | data Expr = Int Integer -- ^ An integer literal. 17 | | Float Double -- ^ An floating-point literal. 18 | | String Interp -- ^ A string literal with interpolated expressions. 19 | | Variable Name -- ^ A variable. 20 | | Constructor Name -- ^ A constructor (e.g. @Just@, @False@, etc). 21 | | Typed Expr Type -- ^ An expression with annotated type. 22 | | Lambda Name Expr -- ^ A lambda expression. 23 | | Let Name Expr Expr -- ^ A let expression. 24 | | Apply Expr Expr -- ^ An application. 25 | | Dot Expr Name -- ^ A field dereference. 26 | | List (Vector Expr) -- ^ A list literal. 27 | | If Expr Expr Expr -- ^ A conditional expression. 28 | | Case Expr [(Pattern, Expr)] -- ^ A case statement. 29 | | Record (Record Expr) -- ^ A record literal. 30 | deriving (Show, Eq) 31 | 32 | -- | Patterns are just expressions, although they're used differently. 33 | type Pattern = Expr 34 | 35 | -- | A string with interpolated expressions. 36 | data Interp = Plain Text 37 | | Interp Interp Expr Interp 38 | deriving (Show, Eq) 39 | 40 | instance IsString Expr where 41 | fromString "" = error "Empty variable string" 42 | fromString var@(c:_) | isUpper c = Constructor $ fromString var 43 | | otherwise = Variable $ fromString var 44 | 45 | instance IsList Expr where 46 | type Item Expr = Expr 47 | fromList = List . GHC.fromList 48 | toList (List es) = GHC.toList es 49 | toList _ = error "Not a list expression" 50 | 51 | instance Render Expr where 52 | render = \case 53 | Int i -> render i 54 | Float f -> render f 55 | String t -> render t 56 | Constructor name -> name 57 | Variable name -> name 58 | Typed expr typ -> render expr <> " :: " <> render typ 59 | Lambda name e2 -> "λ" <> name <> " -> " <> render e2 60 | Let name e1 e2 -> "let " <> name <> " = " <> render e1 <> "; " <> render e2 61 | Apply (Apply (Variable name) e1) e2 | isOp name -> 62 | renderParens e1 <> " " <> name <> " " <> renderParens e2 63 | Apply (e1@(Apply _ _)) e2 -> render e1 <> " " <> renderParens e2 64 | Apply e1 e2 -> renderParens e1 <> " " <> renderParens e2 65 | Dot e name -> renderParens e <> "." <> name 66 | Record fields -> "(" <> T.intercalate ", " (join fields) <> ")" where 67 | join = map joinNE . H.toList 68 | joinNE (name, expr) = name <> ": " <> render expr 69 | List es -> "[" <> T.intercalate ", " renderedList <> "]" where 70 | renderedList = toList $ map render es 71 | Case e alts -> "if " <> render e <> " is " <> showAlts where 72 | showAlts = T.intercalate " | " $ map showAlt alts 73 | showAlt (p, e) = render p <> " -> " <> render e 74 | e -> pack $ show e 75 | renderParens e = case e of 76 | Apply _ _ -> parens 77 | Typed _ _ -> parens 78 | Lambda _ _ -> parens 79 | _ -> render e 80 | where parens = "(" <> render e <> ")" 81 | 82 | instance IsString Interp where 83 | fromString = Plain . fromString 84 | 85 | instance Render Interp where 86 | render interp = "\"" <> go interp <> "\"" where 87 | go (Plain text) = text 88 | go (Interp in1 expr in2) = go in1 <> "$(" <> render expr <> ")" <> go in2 89 | 90 | instance Monoid Interp where 91 | mempty = Plain "" 92 | mappend (Plain s1) (Plain s2) = Plain (s1 <> s2) 93 | mappend interp (Interp in1 e in2) = Interp (mappend interp in1) e in2 94 | mappend (Interp in1 e in2) interp = Interp in1 e (mappend in2 interp) 95 | 96 | 97 | instance Semigroup Interp where 98 | (<>) = mappend 99 | 100 | addChar :: Interp -> Char -> Interp 101 | addChar interp c = interp <> Plain (singleton c) 102 | 103 | -- | Characters legal in symbols. 104 | symChars :: P.String 105 | symChars = "+-/*:|&^%$><" 106 | 107 | -- | A binary expression is syntactic sugar for a nested application. 108 | binary :: Expr -> Name -> Expr -> Expr 109 | binary e1 op e2 = Apply (Apply (Variable op) e1) e2 110 | 111 | -- | Tests if the string is an operator (symbol). 112 | isOp :: Text -> Bool 113 | isOp = T.all (`S.member` (S.fromList symChars)) 114 | 115 | -- | "Unrolls" an application into its left-most function and its arguments. 116 | unroll :: Expr -> (Expr, [Expr]) 117 | unroll (Apply a b) = let (f, xs) = unroll a in (f, xs `snoc` b) 118 | unroll e = (e, []) 119 | 120 | -- | The free variables here are those in the interpolated expressions. 121 | instance FreeVars Interp where 122 | freevars (Interp i1 e i2) = freevars i1 <> freevars e <> freevars i2 123 | freevars _ = mempty 124 | 125 | -- | Collects variables; removes those bound by `Let` and `Lambda`. 126 | instance FreeVars Expr where 127 | freevars = \case 128 | Variable name -> S.singleton name 129 | String interp -> freevars interp 130 | Typed e _ -> freevars e 131 | Lambda name e -> S.delete name $ freevars e 132 | Case e alts -> freevars e <> freeAlts where 133 | freeAlts = concatMap (\(p, e) -> freevars e \\ freevars p) alts 134 | Let name e1 e2 -> S.delete name $ freevars e1 <> freevars e2 135 | Apply e1 e2 -> freevars e1 <> freevars e2 136 | Dot e _ -> freevars e 137 | List es -> concatMap freevars es 138 | Record es -> concatMap freevars es 139 | If e1 e2 e3 -> freevars e1 <> freevars e2 <> freevars e3 140 | _ -> mempty 141 | -------------------------------------------------------------------------------- /src/Language/Rowling/Definitions/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, LambdaCase, FlexibleInstances, 2 | OverloadedLists, TypeSynonymInstances, 3 | FlexibleContexts #-} 4 | module Language.Rowling.Definitions.Types where 5 | 6 | import qualified Prelude as P 7 | import Data.Char (isLower) 8 | import qualified Data.HashMap.Strict as H 9 | import Data.Text (Text, strip, head, length) 10 | import qualified Data.Set as S 11 | import qualified Data.Text as T 12 | import qualified Data.List as L 13 | import Data.String (IsString(..)) 14 | import Data.Traversable 15 | 16 | import Language.Rowling.Common hiding (head, length) 17 | 18 | -- | The type of expressions. 19 | data Type 20 | -- | A record type. The optional name is a type variable for the "rest" of 21 | -- the record, i.e., fields additional to the ones given. If `Nothing`, then 22 | -- the type is considered exact. 23 | = TRecord (HashMap Name Type) (Maybe Name) 24 | -- | A type constant, such as @List@ or @Int@. 25 | | TConst Name 26 | -- | A type variable, which can be later unified to a specific type, or can 27 | -- be left in for a polymorphic type. 28 | | TVar Name 29 | -- | Two types applied to each other. For example, @Just 1@ is the @Maybe@ 30 | -- type applied to the @Int@ type. 31 | | TApply Type Type 32 | deriving (Show, Eq) 33 | 34 | instance Render Type where 35 | render t = case t of 36 | TConst name -> name 37 | TVar name -> name 38 | TApply (TApply (TConst "->") t1) t2 -> 39 | renderParens t1 <> " -> " <> render t2 40 | TApply (t1@(TApply _ _)) t2 -> render t1 <> " " <> renderParens t2 41 | TApply t1 t2 -> renderParens t1 <> " " <> renderParens t2 42 | TRecord row r -> "(" <> inside <> renderRest r <> ")" where 43 | inside = case splitRow row of 44 | -- Only non-numeric keys 45 | ([], named) -> commas renderPair named 46 | -- Only numeric keys 47 | (vals, []) -> commas render vals 48 | -- Mixture of the two 49 | (vals, named) -> commas render vals <> ", " <> commas renderPair named 50 | where 51 | renderRest r = case r of 52 | Nothing -> "" 53 | Just name -> " | " <> name 54 | commas rndr = intercalate ", " . map rndr 55 | renderPair (field, typ) = field <> ": " <> render typ 56 | -- | Splits a row into the fields which have numeric names (0, 1, ...) 57 | -- and the ones that have "normal" names. 58 | splitRow :: HashMap Name Type -> ([Type], [(Name, Type)]) 59 | splitRow row = (snd <$> nums', withNames) where 60 | (withNums, withNames) = L.partition (isNumber . fst) $ H.toList row 61 | toNum :: (Name, Type) -> (Int, Type) 62 | toNum (name, t) = (P.read (unpack name) :: Int, t) 63 | nums' = L.sortBy (\(a, _) (b, _) -> compare a b) (map toNum withNums) 64 | renderParens t@(TApply _ _) = "(" <> render t <> ")" 65 | renderParens t = render t 66 | 67 | instance Default Type where 68 | def = TRecord mempty Nothing 69 | 70 | -- | Checks if the type on the left is at least as general as the type on 71 | -- the right. For example, a type variable is at least as general as anything, 72 | -- a `Float` is at least as general as an `Int`, etc. 73 | (>==) :: Type -- ^ The type which should be more general (e.g. a parameter). 74 | -> Type -- ^ The type which can be more specific (e.g. an argument). 75 | -> Bool -- ^ If the first type is at least as general as the second. 76 | TRecord fields1 r1 >== TRecord fields2 r2 = 77 | fields1 `vs` fields2 && case (r1, r2) of 78 | (Nothing, Nothing) -> True 79 | (Just _, _) -> True 80 | _ -> False 81 | where 82 | -- | Comparing the generality of two records. 83 | rec1 `vs` rec2 = go $ H.toList rec1 where 84 | go [] = True 85 | go ((field, typ):rest) = case H.lookup field rec2 of 86 | -- If the field doesn't exist in the second record, they're not 87 | -- compatible. 88 | Nothing -> False 89 | -- Otherwise, they must be compatible. 90 | Just typ' -> typ >== typ' && go rest 91 | TConst name1 >== TConst name2 = name1 == name2 92 | TVar _ >== _ = True 93 | TApply t1 t2 >== TApply t3 t4 = t1 >== t3 && t2 >== t4 94 | _ >== _ = False 95 | 96 | instance IsString Type where 97 | fromString s = do 98 | let s' = strip $ pack s 99 | if length s' > 0 && (isLower (head s') || head s' == '$') 100 | then TVar s' 101 | else TConst s' 102 | 103 | -- | Class of things which contain free variables. @freevars@ gets all of the 104 | -- free variables out. For example, the type @a@ has free variables @{a}@, 105 | -- while the type @a -> b@ has free variables @{a, b}@; the type @Maybe (a -> 106 | -- Int) -> b -> c@ has free variables @{a, b, c}@, etc. 107 | class FreeVars a where freevars :: a -> Set Name 108 | instance FreeVars Type where 109 | freevars = \case 110 | TVar n -> S.singleton n 111 | TConst _ -> mempty 112 | TApply t1 t2 -> freevars t1 <> freevars t2 113 | TRecord fields Nothing -> freevars fields 114 | TRecord fields (Just r) -> S.insert r $ mconcat (fmap freevars $ toList fields) 115 | instance FreeVars Polytype where 116 | freevars (Polytype vars t) = freevars t \\ vars 117 | instance FreeVars a => FreeVars (Maybe a) where 118 | freevars Nothing = mempty 119 | freevars (Just x) = freevars x 120 | instance FreeVars b => FreeVars (a, b) where 121 | freevars = freevars . snd 122 | instance FreeVars a => FreeVars [a] where 123 | freevars = mconcat . fmap freevars 124 | instance FreeVars a => FreeVars (HashMap x a) where 125 | freevars = freevars . H.elems 126 | 127 | data Polytype = Polytype (Set Name) Type deriving (Show, Eq) 128 | 129 | instance IsString Polytype where 130 | fromString = polytype . fromString 131 | 132 | -- | Stores names that we've typed. 133 | type TypeMap = HashMap Name Polytype 134 | 135 | instance Default TypeMap where 136 | def = mempty 137 | 138 | -- | Stores type aliases. 139 | type AliasMap = HashMap Name Type 140 | 141 | instance Default AliasMap where 142 | def = mempty 143 | 144 | -- | Normalizing means replacing obscurely-named type variables with letters. 145 | -- For example, the type @(t$13 -> [t$4]) -> t$13@ would be @(a -> b) -> a@. 146 | -- The best way to do this is with a state monad so that we can track which 147 | -- renamings have been done. So the only method that we need is @normalizeS@ 148 | -- (@S@ for state monad). This lets us normalize across multiple types. 149 | class Normalize t where 150 | normalizeS :: t -> State (Text, HashMap Name Name) t 151 | 152 | -- | Normalizes starting with `a`. 153 | normalize :: Normalize a => a -> a 154 | normalize = normalizeWith ("a", mempty) 155 | 156 | -- | Normalizes given some initial starting point. 157 | normalizeWith :: Normalize a => (Text, HashMap Name Name) -> a -> a 158 | normalizeWith state x = evalState (normalizeS x) state 159 | 160 | instance Normalize Type where 161 | normalizeS type_ = case type_ of 162 | TVar name -> TVar <$> normalizeS name 163 | TApply a b -> TApply <$> normalizeS a <*> normalizeS b 164 | TRecord row rest -> TRecord <$> normalizeS row <*> normalizeS rest 165 | _ -> return type_ 166 | 167 | instance (Normalize a, Traversable f) => Normalize (f a) where 168 | normalizeS = mapM normalizeS 169 | 170 | instance Normalize Text where 171 | normalizeS oldName = do 172 | (newName, mapping) <- get 173 | case H.lookup oldName mapping of 174 | Just n -> return n 175 | Nothing -> do put (next newName, H.insert oldName newName mapping) 176 | return newName 177 | 178 | class CanApply a where apply :: a -> a -> a 179 | instance CanApply Type where 180 | apply = TApply 181 | instance CanApply Polytype where 182 | apply (Polytype vs1 t1) (Polytype vs2 t2) = 183 | Polytype (vs1 <> vs2) (apply t1 t2) 184 | 185 | -- | The function type, which is actually a rank-2 type applied twice. 186 | (==>) :: (IsString a, CanApply a) => a -> a -> a 187 | t1 ==> t2 = apply (apply "->" t1) t2 188 | infixr 3 ==> 189 | 190 | -- | Creates a polytype out of a type. Somewhat hacky. 191 | polytype :: Type -> Polytype 192 | polytype = Polytype mempty 193 | 194 | -- | Creates an exact (non-extensible) record type from a list of fields. 195 | tRecord :: [(Name, Type)] -> Type 196 | tRecord fields = TRecord (H.fromList fields) Nothing 197 | 198 | -- | Creates an extensible record type from a list of fields. 199 | tRecord' :: [(Name, Type)] -> Name -> Type 200 | tRecord' fields name = TRecord (H.fromList fields) (Just name) 201 | 202 | -- | Checks if the string is a number. 203 | isNumber :: Text -> Bool 204 | isNumber = T.all isDigit 205 | 206 | -- | Generates the next name in the "fresh name sequence". This sequence is: 207 | -- @a, b, c, ..., z, za, zb, zc, ... zz, zza, zzb, zzc...@ 208 | next :: Text -> Text 209 | next name = case T.last name of 210 | c | c < 'z' -> T.init name `T.snoc` succ c 211 | | True -> name `T.snoc` 'a' 212 | 213 | listOf :: Type -> Type 214 | listOf = TApply "List" 215 | -------------------------------------------------------------------------------- /src/Language/Rowling/Definitions/Values.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE OverloadedLists #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | -- | Describes Rowling values, i.e., the entities which are produced by 8 | -- evaluating expressions, and passed as input to the evaluator. 9 | module Language.Rowling.Definitions.Values where 10 | 11 | import Data.Aeson (FromJSON(..), ToJSON(..), (.=), object) 12 | import qualified Data.Aeson as Aeson 13 | import Data.ContextStack 14 | import qualified Data.HashMap.Strict as H 15 | import Data.Scientific (isInteger, toRealFloat, fromFloatDigits) 16 | import qualified GHC.Exts as GHC 17 | 18 | import Language.Rowling.Common 19 | import Language.Rowling.Definitions.Expressions 20 | 21 | -- | The evaluated form of an `Expr`. 22 | data Value = VInt !Integer -- ^ An integer. 23 | | VFloat !Double -- ^ A floating-point number. 24 | | VString !Text -- ^ A string. 25 | | VBool !Bool -- ^ A boolean. 26 | | VArray !(Vector Value) -- ^ An array of values. 27 | | VTagged !Name !(Vector Value) 28 | -- ^ A tagged union, like `Either` or `List`. 29 | | VMaybe !(Maybe Value) 30 | -- ^ A maybe (using the Haskell type for efficiency) 31 | | VBuiltin !Builtin -- ^ A builtin function. 32 | | VRecord !(Record Value) -- ^ An instantiated Record. 33 | | VClosure !(Record Value) !Pattern !Expr -- ^ A closure. 34 | deriving (Show, Eq) 35 | 36 | -- | Looks up a field in a record. If the field doesn't exist, or the value 37 | -- isn't a record, an IO exception will be thrown. 38 | deref :: Name -> Value -> Value 39 | deref name (VRecord fields) = case H.lookup name fields of 40 | Nothing -> error $ "No field " <> show name 41 | Just val -> val 42 | deref _ _ = error "Not a record value" 43 | 44 | instance Render Value 45 | 46 | -- | The default value is an empty record, akin to @()@. 47 | instance Default Value where 48 | def = VRecord mempty 49 | 50 | -- | Makes creating string values more convenient. 51 | instance IsString Value where 52 | fromString = VString . fromString 53 | 54 | -- | Array values are lists, that contain values. 55 | instance IsList Value where 56 | type Item Value = Value 57 | fromList = VArray . GHC.fromList 58 | toList (VArray vs) = GHC.toList vs 59 | toList _ = error "Not a list value" 60 | 61 | -- | Values can be read out of JSON. Of course, closures and builtins 62 | -- can't be represented. 63 | instance FromJSON Value where 64 | parseJSON (Aeson.Object v) = VRecord <$> mapM parseJSON v 65 | parseJSON (Aeson.Array arr) = VArray <$> mapM parseJSON arr 66 | parseJSON (Aeson.String s) = return $ VString s 67 | parseJSON (Aeson.Bool b) = return $ VBool b 68 | parseJSON (Aeson.Number n) 69 | | isInteger n = return $ VInt (floor n) 70 | | otherwise = return $ VFloat $ toRealFloat n 71 | parseJSON _ = mzero 72 | 73 | 74 | -- | Most values have JSON representations. Where they don't, it's an error 75 | -- to try to serialize them to JSON. 76 | instance ToJSON Value where 77 | toJSON (VInt i) = Aeson.Number $ fromIntegral i 78 | toJSON (VFloat f) = Aeson.Number $ fromFloatDigits f 79 | toJSON (VString txt) = Aeson.String txt 80 | toJSON (VBool b) = Aeson.Bool b 81 | toJSON (VArray arr) = Aeson.Array $ map toJSON arr 82 | toJSON (VMaybe Nothing) = object ["@constructor" .= Aeson.String "None"] 83 | toJSON (VMaybe (Just v)) = object [ 84 | "@constructor" .= Aeson.String "Some", 85 | "@values" .= Aeson.Array [toJSON v] 86 | ] 87 | toJSON (VTagged name vals) = object ["@constructor" .= name, 88 | "@values" .= map toJSON vals] 89 | toJSON (VRecord rec) = Aeson.Object $ map toJSON rec 90 | toJSON v = errorC ["Can't serialize '", render v, "' to JSON"] 91 | 92 | -- | Matches a pattern against a value and either fails, or returns a map of 93 | -- name bindings. For example, matching the pattern @Just x@ against the value 94 | -- @VTagged "Just" (VInt 1)@ would return @[("x", VInt 1)]@. Matching the 95 | -- same pattern against @VFloat 2.3@ would return @Nothing@. 96 | patternMatch :: Pattern -> Value -> Maybe (Record Value) 97 | patternMatch p v = case (p, v) of 98 | -- Primitive literals just match if equal. (Constructors are literals). 99 | (Int n, VInt vn) | n == vn -> Just mempty 100 | (Float n, VFloat vn) | n == vn -> Just mempty 101 | (String (Plain s), VString vs) | s == vs -> Just mempty 102 | -- True and false are constructors, but use Haskell bools 103 | (Constructor "True", VBool True) -> Just mempty 104 | (Constructor "False", VBool False) -> Just mempty 105 | (Constructor "None", VMaybe Nothing) -> Just mempty 106 | (Apply (Constructor "Some") p, VMaybe (Just v)) -> patternMatch p v 107 | -- A variable can match with anything. 108 | (Variable name, v) -> Just [(name, v)] 109 | -- With a list expression, it matches if and only if all of them match. 110 | (List ps, VArray vs) -> matchVector ps vs 111 | (Record precord, VRecord vrecord) -> matchRecord precord vrecord 112 | -- For a compound expression, dive into it (see below). 113 | (compoundExpr, VTagged n' vs) -> case dive compoundExpr of 114 | Just (n, ps) | n == n' -> matchVector (fromList ps) vs 115 | otherwise -> Nothing 116 | -- Anything else is not a match. 117 | otherwise -> Nothing 118 | where 119 | matchRecord precord vrecord = loop mempty $ H.toList precord where 120 | loop bindings [] = Just bindings 121 | loop bindings ((key, pattern):rest) = case lookup key vrecord of 122 | -- Key doesn't exist, pattern match fails. 123 | Nothing -> Nothing 124 | Just val -> case patternMatch pattern val of 125 | -- Value doesn't pattern match with pattern, no match. 126 | Nothing -> Nothing 127 | Just bindings' -> loop (bindings' <> bindings) rest 128 | matchVector ps vs = case length ps == length vs of 129 | True -> concat <$> mapM (uncurry patternMatch) (zip ps vs) 130 | False -> Nothing 131 | -- "Dives" into a pattern and grabs the constructor name and patterns. 132 | -- Note that it's only going to return a @Just@ value if the "left most" 133 | -- expression in the pattern is a constructor. This prevents an pattern 134 | -- like @a b@ from matching against @Just 1@. 135 | dive = map (map reverse) . dive' where 136 | dive' (Constructor n) = Just (n, []) 137 | dive' (Apply p1 p2) = for (dive' p1) (\(name, ps) -> (name, p2:ps)) 138 | dive' _ = Nothing 139 | 140 | ------------------------------------------------------------------------------ 141 | -- * The Evaluator Monad 142 | -- Note: we have to put these definitions here because `Value`s need to be 143 | -- aware of the `Eval` type. 144 | ------------------------------------------------------------------------------ 145 | 146 | -- | An evaluation frame. It consists of the argument passed into the 147 | -- function currently being evaluated, and all of the variables in the 148 | -- current scope. 149 | data EvalFrame = EvalFrame { 150 | _fArgument :: Value, 151 | _fEnvironment :: Record Value 152 | } deriving (Show) 153 | 154 | -- | A frame is a key-value store where the internal dictionary is the 155 | -- environment. 156 | instance KeyValueStore EvalFrame where 157 | type LookupKey EvalFrame = Name 158 | type StoredValue EvalFrame = Value 159 | empty = def 160 | loadBindings bs f = f {_fEnvironment = bs <> _fEnvironment f} 161 | getValue name = lookup name . _fEnvironment 162 | putValue name val frame = frame {_fEnvironment = insertMap name val env} 163 | where env = _fEnvironment frame 164 | 165 | -- | The evaluator's state is a stack of evaluation frames. 166 | data EvalState = EvalState {_esStack :: [EvalFrame]} deriving (Show) 167 | 168 | -- | The evaluator state is a stack of `EvalFrame`s. 169 | instance Stack EvalState where 170 | type Frame EvalState = EvalFrame 171 | push frame state = state {_esStack = push frame $ _esStack state} 172 | pop state = (top, state {_esStack=rest}) where 173 | top:rest = _esStack state 174 | asList = _esStack 175 | modifyTop func state = state {_esStack=func top : rest} where 176 | top:rest = _esStack state 177 | 178 | -- | The default evaluation state is a stack with a single evaluation frame. 179 | instance Default EvalState where 180 | def = EvalState {_esStack = [def]} 181 | 182 | -- | The default evaluation frame just takes default arguments and 183 | -- environment. 184 | instance Default EvalFrame where 185 | def = EvalFrame {_fArgument = def, _fEnvironment = mempty} 186 | 187 | -- | The evaluator monad. 188 | type Eval = ReaderT () (StateT EvalState IO) 189 | 190 | -- | A built-in function. Allows us to write functions in Haskell and 191 | -- make them callable from inside the Rowling evaluator. 192 | data Builtin = Builtin Name (Value -> Eval Value) 193 | 194 | -- | All we show is the function's name, which is assumed to be unique. 195 | instance Show Builtin where 196 | show (Builtin n _) = " show n <> ">" 197 | 198 | -- | Builtins are considered equal if they have the same name. 199 | instance Eq Builtin where 200 | Builtin n1 _ == Builtin n2 _ = n1 == n2 201 | -------------------------------------------------------------------------------- /src/Language/Rowling/Evaluator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Language.Rowling.Evaluator where 3 | 4 | import Prelude (String) 5 | import Language.Rowling.Common 6 | import Language.Rowling.Definitions 7 | import Language.Rowling.Evaluator.Evaluator 8 | import Language.Rowling.Evaluator.Builtins 9 | import Language.Rowling.Parser 10 | 11 | -- * Running the evaluator monad. 12 | 13 | -- ** Evaluating with returned state 14 | 15 | -- | Runs an evaluator with only the builtin bindings. 16 | runEval :: Eval a -> IO (a, EvalState) 17 | runEval = runEvalWith [def {_fEnvironment = builtins}] 18 | 19 | -- | Runs an evaluator with the given frames as initial state. 20 | runEvalWith :: [EvalFrame] -> Eval a -> IO (a, EvalState) 21 | runEvalWith initFrames action = runStateT action' initState 22 | where 23 | action' = runReaderT action () 24 | initState = def {_esStack = initFrames} 25 | 26 | -- ** Evaluating strings 27 | 28 | -- | Evaluates a raw expression string into a value. Throws IO errors if 29 | -- the string doesn't parse, if the expression is ill-typed, or if there's a 30 | -- runtime failure during evaluation. 31 | evalIt :: String -> IO Value 32 | evalIt input = case parseIt input of 33 | Left err -> error $ show err 34 | Right expr -> fst <$> runEval (eval expr) 35 | 36 | -- ** Evalutating ASTs 37 | 38 | -- | Evaluates an expression with only the builtin bindings. 39 | evalExpr :: Expr -> IO Value 40 | evalExpr = evalWithBindings mempty 41 | 42 | -- | Evaluates an expression with the given bindings and builtins. 43 | evalWithBindings :: Record Value -> Expr -> IO Value 44 | evalWithBindings bindings expr = do 45 | let baseFrame = def {_fEnvironment = builtins} 46 | startFrame = def {_fEnvironment = bindings} 47 | fst <$> runEvalWith [startFrame, baseFrame] (eval expr) 48 | -------------------------------------------------------------------------------- /src/Language/Rowling/Evaluator/Builtins.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, LambdaCase, 2 | RecordWildCards, OverloadedLists, 3 | FlexibleContexts, NoMonomorphismRestriction #-} 4 | module Language.Rowling.Evaluator.Builtins (builtins) where 5 | 6 | import qualified Prelude as P 7 | import Data.HashMap.Strict (HashMap) 8 | import qualified Data.HashMap.Strict as H 9 | import qualified Data.Set as S 10 | import Data.String (IsString(..)) 11 | 12 | import Language.Rowling.Common 13 | import Language.Rowling.Definitions.Expressions 14 | import Language.Rowling.Definitions.Values 15 | import Language.Rowling.Evaluator.Evaluator 16 | 17 | builtins :: HashMap Name Value 18 | builtins = 19 | [ 20 | ("+", builtinBinary "+" (+) (+)), 21 | ("-", builtinBinary "-" (-) (-)), 22 | ("*", builtinBinary "*" (*) (*)), 23 | ("/", builtinBinary "/" div (/)), 24 | (">", builtinBinaryComp ">" (>) (>)), 25 | ("<", builtinBinaryComp "<" (<) (<)), 26 | (">=", builtinBinaryComp ">=" (>=) (>=)), 27 | ("<=", builtinBinaryComp "<=" (<=) (<=)), 28 | ("==", builtinBinaryComp "==" (==) (==)), 29 | ("!=", builtinBinaryComp "!=" (/=) (/=)), 30 | ("&&", VBuiltin $ builtinBinaryBool "and" (&&)), 31 | ("||", VBuiltin $ builtinBinaryBool "or" (||)), 32 | ("not", VBuiltin builtinNot), 33 | ("each", VBuiltin builtinEach) 34 | ] 35 | 36 | -- | Shorthand for wrapping a function as a builtin. 37 | bi :: Name -> (Value -> Eval Value) -> Value 38 | bi name = VBuiltin . Builtin name 39 | 40 | -- | Takes an operator for integers and for doubles, and makes a builtin 41 | -- of it. 42 | builtinBinary :: Name -> (Integer -> Integer -> Integer) 43 | -> (Double -> Double -> Double) 44 | -> Value 45 | builtinBinary name i2i f2f = bi name $ \case 46 | VInt n -> return $! builtinInt n 47 | VFloat f -> return $! builtinFloat f 48 | _ -> error "Not a number" 49 | where builtinInt n = bi (render n <> name) $ \case 50 | VInt n' -> return $! VInt $ n `i2i` n' 51 | VFloat f -> return $! VFloat $ fromInteger n `f2f` f 52 | _ -> error "Not a number" 53 | builtinFloat f = bi (render f <> name) $ \case 54 | VInt n -> return $ VFloat $ f `f2f` fromInteger n 55 | VFloat f' -> return $ VFloat $ f `f2f` f' 56 | _ -> error "Not a number" 57 | 58 | builtinBinaryComp :: Name -> (Integer -> Integer -> Bool) 59 | -> (Double -> Double -> Bool) 60 | -> Value 61 | builtinBinaryComp name i2i f2f = bi name $ \case 62 | VInt n -> return $ builtinInt n 63 | VFloat f -> return $ builtinFloat f 64 | _ -> error "Not a number" 65 | where builtinInt n = bi (render n <> name) $ \case 66 | VInt n' -> return $ VBool $ n `i2i` n' 67 | VFloat f -> return $ VBool $ fromInteger n `f2f` f 68 | _ -> error "Not a number" 69 | builtinFloat f = bi (render f <> name) $ \case 70 | VInt n -> return $ VBool $ f `f2f` fromInteger n 71 | VFloat f' -> return $ VBool $ f `f2f` f' 72 | _ -> error "Not a number" 73 | 74 | builtinBinaryBool :: Name -> (Bool -> Bool -> Bool) -> Builtin 75 | builtinBinaryBool name op = Builtin name $ \case 76 | VBool b -> return $ bi (name <> "(" <> render b <> ")") $ \case 77 | VBool b' -> return $ VBool $ b `op` b' 78 | _ -> error "Not a bool" 79 | _ -> error "Not a bool" 80 | 81 | builtinNot :: Builtin 82 | builtinNot = Builtin "not" $ \case 83 | VBool b -> return $ VBool (not b) 84 | _ -> error "Not a bool" 85 | 86 | builtinEach :: Builtin 87 | builtinEach = Builtin "each" $ \case 88 | VArray vals -> return $! eachVals vals 89 | _ -> error "Not a list" 90 | where 91 | eachVals vals = bi "eachApplied" $ \func -> do 92 | let applyFunc val = case func of 93 | VClosure _ _ _ -> error "Can't handle closures here" 94 | VBuiltin (Builtin _ builtin) -> builtin val 95 | results <- mapM applyFunc vals 96 | return $ VArray results 97 | -------------------------------------------------------------------------------- /src/Language/Rowling/Evaluator/Evaluator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE OverloadedLists #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | module Language.Rowling.Evaluator.Evaluator where 7 | 8 | import qualified Prelude as P 9 | import Data.HashMap.Strict (HashMap) 10 | import qualified Data.HashMap.Strict as H 11 | import qualified Data.Set as S 12 | import Data.String (IsString(..)) 13 | import Data.ContextStack 14 | 15 | import Language.Rowling.Common 16 | import Language.Rowling.Definitions 17 | 18 | -- | Evaluates an expression into a value. 19 | eval :: Expr -> Eval Value 20 | eval !expr = case expr of 21 | Int i -> return $ VInt i 22 | Float f -> return $ VFloat f 23 | String interp -> loop interp where 24 | loop (Plain s) = return $ VString s 25 | loop (Interp in1 e in2) = do 26 | VString s1 <- loop in1 27 | e' <- render <$> eval e 28 | VString s2 <- loop in2 29 | return $ VString $ s1 <> e' <> s2 30 | Constructor "True" -> return $ VBool True 31 | Constructor "False" -> return $ VBool False 32 | Constructor n -> return $ VTagged n [] 33 | Variable var -> findOrHardError var 34 | Typed expr _ -> eval expr 35 | Lambda param body -> do 36 | env <- getClosure expr 37 | return $ VClosure env (Variable param) body 38 | Let var e1 e2 -> do 39 | modifyTopM . putValue var =<< eval e1 40 | eval e2 41 | Case e alts -> eval e >>= go alts where 42 | ps = fst <$> alts 43 | go [] v = errorC ["Pattern match failure: value ", render v, 44 | " does not match any of the given patterns: ", 45 | render ps] 46 | go ((pat, ex):rest) v = case patternMatch pat v of 47 | Nothing -> go rest v 48 | Just bs -> loadBindingsM bs >> eval ex 49 | Apply e1 e2 -> do 50 | arg <- eval e2 51 | eval e1 >>= \case 52 | -- See if the lambda's parameter matches the argument. 53 | VClosure env param body -> case patternMatch param arg of 54 | -- If it doesn't, it's an error! 55 | Nothing -> errorC ["Pattern match failure: argument ", render arg, 56 | " does not match pattern ", render param] 57 | -- Otherwise, load the bindings and evaluate the body. 58 | Just bs -> withFrame (EvalFrame arg (bs <> env)) $ eval body 59 | VTagged n vs -> return $ VTagged n (vs ++ [arg]) 60 | VBuiltin (Builtin _ func) -> func arg 61 | Dot expr name -> deref name <$> eval expr 62 | Record fields -> VRecord <$> mapM eval fields 63 | List exprs -> VArray <$> mapM eval exprs 64 | If test ifTrue ifFalse -> eval test >>= \case 65 | VBool True -> eval ifTrue 66 | VBool False -> eval ifFalse 67 | val -> errorC ["Non-boolean test for if expression: ", render val] 68 | 69 | -- | Calculates the closure (variables inherited from outside scope) of an 70 | -- expression. Only gets free variables, not bound. For example, in the 71 | -- expression @λx -> f x 1@, the variable @x@ is bound, while the variable 72 | -- @f@ is free. Therefore, @f@ will wind up in the closure, while @x@ won't. 73 | getClosure :: Expr -> Eval (Record Value) 74 | getClosure = flip evalStateT [] . loop where 75 | -- Uses a stack of sets of names to keep track of bound variables. 76 | loop :: Expr -> StateT [Set Name] Eval (Record Value) 77 | loop !(Variable name) = isBound name >>= \case 78 | True -> return mempty 79 | False -> do val <- lift $ findOrHardError name 80 | return [(name, val)] 81 | loop !(Lambda param body) = withName param $ loop body 82 | loop !(Let name e1 e2) = withName name $ loop2 e1 e2 83 | loop !(Apply e1 e2) = loop2 e1 e2 84 | loop !(Record fields) = foldl' (<>) mempty <$> mapM loop fields 85 | loop !(Typed e _) = loop e 86 | loop !(Dot e _) = loop e 87 | loop !(Case e alts) = map concat $ mapM go alts where 88 | go (p, e) = withNames (getNames p) (loop e) 89 | loop _ = return mempty 90 | loop2 a b = mappend <$> loop a <*> loop b 91 | withNames names action = modify (names :) *> action <* modify P.tail 92 | withName n = withNames (S.singleton n) 93 | isBound name = get >>= look where 94 | look [] = return False 95 | look (names:rest) = if S.member name names then return True else look rest 96 | 97 | -- | Gets the variable names out of a pattern. These variables are bound in 98 | -- downstream scopes. 99 | getNames :: Pattern -> Set Name 100 | getNames !(Variable name) = S.singleton name 101 | getNames !(Record fields) = foldl' (<>) mempty $ fmap getNames fields 102 | getNames !(Apply e1 e2) = getNames e1 <> getNames e2 103 | getNames _ = mempty 104 | -------------------------------------------------------------------------------- /src/Language/Rowling/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, OverloadedLists, LambdaCase #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Language.Rowling.Parser where 5 | 6 | import qualified Prelude as P 7 | import Data.Char (isAlpha) 8 | import qualified Data.HashMap.Strict as H 9 | import qualified Data.Set as S 10 | import qualified GHC.Exts as GHC 11 | import Prelude (String) 12 | import Text.Parsec hiding (many, (<|>), spaces, parse) 13 | import qualified Text.Parsec as Parsec 14 | 15 | import Language.Rowling.Common hiding (try) 16 | import Language.Rowling.Definitions 17 | 18 | -- | The parser state, if any. 19 | type ParserState = () 20 | 21 | -- | The parser type. 22 | type Parser = ParsecT String ParserState Identity 23 | 24 | ------------------------------------------------------------------------------ 25 | -- * Basics 26 | ------------------------------------------------------------------------------ 27 | 28 | -- | Set of keywords. 29 | keywords :: Set Text 30 | keywords = S.fromList ["if", "then", "else", "is", "true", "false", 31 | "let", "with", "without"] 32 | 33 | -- | Set of reserved symbols. 34 | keysymbols :: Set Text 35 | keysymbols = S.fromList ["->", "::", ":", "|", "="] 36 | 37 | -- | Consumes any spaces (not other whitespace). 38 | spaces :: Parser String 39 | spaces = many $ char ' ' 40 | 41 | -- | Parses the given string and any trailing spaces. 42 | sstring :: String -> Parser String 43 | sstring = lexeme . string 44 | 45 | -- | Parses the given character and any trailing spaces. 46 | schar :: Char -> Parser Char 47 | schar = lexeme . char 48 | 49 | -- | Parses `p` and any trailing spaces. 50 | lexeme :: Parser a -> Parser a 51 | lexeme p = p <* spaces 52 | 53 | -- | Parses the given string. Does not fail if it's a keyword. 54 | keyword :: String -> Parser String 55 | keyword = try . sstring 56 | 57 | -- | Parses an identifier starting with a lower-case letter or underscore. 58 | lowerIdent :: Parser Text 59 | lowerIdent = lexeme lowerIdent' 60 | 61 | -- | Parses an identifier, but doesn't consume trailing whitespace. 62 | lowerIdent' :: Parser Text 63 | lowerIdent' = do 64 | first <- lower 65 | rest <- many $ letter <|> digit <|> char '_' 66 | return $ pack $ first : rest 67 | 68 | -- | Parses an identifier starting with an upper-case letter or underscore. 69 | upperIdent :: Parser Text 70 | upperIdent = lexeme $ do 71 | first <- upper 72 | rest <- many $ letter <|> digit <|> char '_' 73 | return $ pack $ first : rest 74 | 75 | -- | Parses `p`, but fails if the result is a reserved word. 76 | notKeyword :: Parser Text -> Parser Text 77 | notKeyword p = try $ do 78 | ident <- p 79 | if ident `member` keywords then unexpected $ "keyword " <> show ident 80 | else return ident 81 | 82 | -- | Parses an integer. 83 | pInt :: Parser Integer 84 | pInt = P.read <$> many1 digit 85 | 86 | -- | Parses a float (must have a dot and digits on both sides). 87 | pFloat :: Parser Double 88 | pFloat = fmap P.read $ try $ do 89 | first <- many1 digit 90 | dot <- char '.' 91 | rest <- many1 digit 92 | return $ first <> [dot] <> rest 93 | 94 | -- | Parses a reserved symbol. 95 | keysymbol :: Text -> Parser Text 96 | keysymbol s = lexeme . try $ do 97 | sym <- many1 $ oneOf symChars 98 | if pack sym == s then return s 99 | else unexpected $ show sym <> " is not a " <> show s 100 | 101 | -- | Parses any non-reserved symbol. 102 | symbol :: Parser Text 103 | symbol = lexeme $ try $ do 104 | sym <- fmap pack $ many1 $ oneOf symChars 105 | if sym `member` keysymbols then unexpected $ "keysymbol " <> show sym 106 | else return sym 107 | 108 | -- | Parses a non-keyword lower-case-starting identifier. 109 | identifier :: Parser Text 110 | identifier = notKeyword lowerIdent 111 | 112 | -- | Parses anything that can be in a keypath, including digits. 113 | keyPathVar :: Parser Text 114 | keyPathVar = anyIdentifier <|> fmap render pInt 115 | 116 | -- | Parses any identifier (upper- or lower-case). 117 | anyIdentifier :: Parser Text 118 | anyIdentifier = upperIdent <|> lowerIdent 119 | 120 | ------------------------------------------------------------------------------ 121 | -- * Strings and interpolated strings 122 | ------------------------------------------------------------------------------ 123 | 124 | pString :: Parser Expr 125 | pString = String . Plain <$> pBasicString 126 | 127 | -- | Parses a string constant, without interpolation. 128 | pBasicString :: Parser Text 129 | pBasicString = do 130 | start <- char '"' <|> char '\'' 131 | loop start ([] :: [Char]) 132 | where 133 | loop stop acc = do 134 | anyChar >>= \case 135 | c | c == stop -> return $ pack $ P.reverse acc 136 | '\\' -> anyChar >>= \case 137 | 'n' -> escape '\n' 138 | 'r' -> escape '\r' 139 | 't' -> escape '\r' 140 | 'b' -> escape '\r' 141 | '\\' -> escape '\\' 142 | '"' -> escape '"' 143 | '\'' -> escape '\'' 144 | c -> unexpected $ "Unrecognized escape sequence: \\" <> [c] 145 | c -> escape c 146 | <|> return (pack $ P.reverse acc) 147 | where escape c = loop stop (c : acc) 148 | 149 | -- | Parses an interpolated string, NOT in quotes. 150 | pInterp :: Parser Interp 151 | pInterp = do 152 | plain <- fromString <$> many (noneOf "$") 153 | option plain $ do 154 | char '$' 155 | lookAhead anyChar >>= \case 156 | -- If it's a letter, grab a variable. 157 | c | isAlpha c -> Interp plain <$> dots <*> pInterp 158 | -- If it's an open parens, grab what's in the parens. 159 | '(' -> Interp plain <$> parens <*> pInterp 160 | -- If there's a backslash, we're escaping whatever's next. 161 | '\\' -> do c <- anyChar >> anyChar 162 | map ((plain `addChar` c) <>) pInterp 163 | -- Otherwise, just keep going and append what we have. 164 | _ -> map (plain <>) pInterp 165 | where dots = map Variable lowerIdent' >>= getDots 166 | getDots expr = do 167 | -- See if there's a period, AND that there is a letter immediately 168 | -- following the period. If so, grab another identifier; otherwise 169 | -- return what we have so far. 170 | option expr $ try $ do 171 | spaces >> char '.' 172 | getDots =<< Dot expr <$> lowerIdent' 173 | parens = between (schar '(') (char ')') pExpr 174 | 175 | 176 | ------------------------------------------------------------------------------ 177 | -- * Expressions 178 | ------------------------------------------------------------------------------ 179 | 180 | -- | Parses an identifier and wraps in a `Variable` expression. 181 | pVariable :: Parser Expr 182 | pVariable = choice [Variable <$> lower, Constructor <$> upperIdent] where 183 | lower = notKeyword lowerIdent 184 | 185 | -- | Parses a number (int or float). 186 | pNumber :: Parser Expr 187 | pNumber = lexeme $ choice [Float <$> pFloat, Int <$> pInt] 188 | 189 | -- | Basic expression terms. 190 | pTerm :: Parser Expr 191 | pTerm = choice [pNumber, pString, pVariable, pParens, pList] 192 | 193 | -- | A binary expression, lambda, or let. Can be annotated with a type. 194 | pExpr :: Parser Expr 195 | pExpr = do e <- choice [pBinary, pLambda, pLet, pIf] 196 | option e $ Typed e <$> (keysymbol "::" *> pType) 197 | 198 | -- | An expression in parentheses. Tuples and record literals are also written 199 | -- this way. 200 | pParens :: Parser Expr 201 | pParens = between (schar '(') (schar ')') getValues where 202 | getValues = do 203 | bareExprs <- getBareExprs 204 | keyVals <- getKeyVals 205 | case (bareExprs, keyVals) of 206 | ([e], []) -> return e 207 | (es, kvs) -> return $ Record $ H.fromList $ makeTuple es <> kvs 208 | getBareExprs = bareExpr `sepEndBy` schar ',' 209 | bareExpr = try $ pExpr <* notFollowedBy (char '=') 210 | getKeyVals = keyVal `sepEndBy` schar ',' 211 | keyVal = (,) <$> identifier <*> (sstring "=" *> pExpr) 212 | 213 | pList :: Parser Expr 214 | pList = grab $ between (schar '[') (schar ']') $ pExpr `sepBy` schar ',' 215 | where grab = map GHC.fromList 216 | 217 | -- | Creates a "tuple" (record with integer fields) from an expression list. 218 | makeTuple :: [Expr] -> [(Text, Expr)] 219 | makeTuple es = map (\(i, e) -> (render i, e)) $ zip [0 :: Int ..] es 220 | 221 | -- | A let statement. 222 | pLet :: Parser Expr 223 | pLet = keyword "let" >> do 224 | expr <- pBinary 225 | body <- schar '=' *> pExpr 226 | case unroll expr of 227 | -- A single, pattern argument; this is a deconstruction. For example, 228 | -- we can rewrite `let Just x = y; z` as `if z is Just x -> y`. 229 | (x, _) | not (isVariable x) -> do 230 | y <- rest 231 | return $ Case body [(expr, y)] 232 | -- A variable on the left means this is a variable definition. 233 | (Variable name, args) -> 234 | if all isVariable args then do 235 | -- If all of the arguments are also variables, or if there are no 236 | -- arguments, then we can just use a simple fold to make a lambda. 237 | -- This also covers the no-argument case. 238 | let names = map (\(Variable v) -> v) args 239 | Let name (foldr Lambda body names) <$> rest 240 | else do 241 | -- If there are restrictions in the arguments, then we need to 242 | -- construct a case statement. And there might be multiple patterns. 243 | -- So use `getOthers` to collect them. 244 | let numArgs = length args 245 | others <- option [] $ schar '|' *> getOthers name numArgs 246 | -- Our full alternatives list is the original pattern and body joined 247 | -- onto the others. 248 | let alts = (toPattern args, body) : others 249 | -- Create a names list, one for each argument. 250 | let params = take numArgs $ map singleton ['a'..] 251 | finalBody = Case (toPattern $ map Variable params) alts 252 | Let name (foldr Lambda finalBody params) <$> rest 253 | where rest = schar ';' *> pExpr 254 | isVariable (Variable _) = True 255 | isVariable _ = False 256 | 257 | -- | Converts multiple patterns into a single pattern, using a list if there 258 | -- is not exactly one element in the argument. 259 | toPattern :: [Pattern] -> Pattern 260 | toPattern exprs = case exprs of [p] -> p; _ -> List $ fromList exprs 261 | 262 | -- | Gets additional alternatives. After grabbing a single function 263 | -- definition, there can be 0 or more additional alternatives for this 264 | -- function. For example: 265 | -- >>> let fact 1 = 0 | fact n = n * fact (n - 1); 266 | -- In this case, the number of arguments would be 1, and the function name 267 | -- would be @fact@. 268 | getOthers :: Name -- ^ The name of the function. 269 | -> Int -- ^ The number of arguments to grab (must be same each time) 270 | -> Parser [(Pattern, Expr)] -- ^ A list of alternatives. 271 | getOthers funcName numArgs = do 272 | -- Get the pattern on the left side. 273 | pattern <- unroll <$> pBinary >>= \case 274 | (Variable f, es) -> do 275 | -- Make sure the function name matches. 276 | when (f /= funcName) $ do 277 | unexpected $ "Expected function named " <> show funcName 278 | -- Make sure the same number of arguments have been declared. 279 | when (length es /= numArgs) $ do 280 | unexpected $ "Wrong number of arguments, expected " <> show numArgs 281 | return $ toPattern es 282 | -- Get the definition. 283 | body <- schar '=' *> pExpr 284 | -- Continue if there's a pipe. 285 | option [(pattern, body)] $ schar '|' >> do 286 | ((pattern, body):) <$> getOthers funcName numArgs 287 | 288 | 289 | 290 | -- | An if statement. 291 | pIf :: Parser Expr 292 | pIf = keyword "if" >> do 293 | cond <- pExpr 294 | getIs cond <|> getThen cond 295 | where 296 | alts = tuple pBinary (keysymbol "->" *> pExpr) `sepBy1` schar '|' 297 | getIs cond = map (Case cond) $ (keyword "is" *> alts) 298 | getThen cond = If cond <$> (keyword "then" *> pExpr) 299 | <*> (keyword "else" *> pExpr) 300 | -- | An expression with a `.` and a field name. 301 | pDot :: Parser Expr 302 | pDot = pTerm >>= getNext where 303 | getNext expr = option expr $ do 304 | next <- schar '.' *> keyPathVar 305 | getNext $ Dot expr next 306 | 307 | -- | An expression applied to another expression. 308 | pApply :: Parser Expr 309 | pApply = pDot `chainl1` (pure Apply) 310 | 311 | -- | A lambda expression. 312 | pLambda :: Parser Expr 313 | pLambda = schar '&' >> do 314 | let alt = tuple pTerm (keysymbol "->" *> pExpr) 315 | alt `sepBy1` schar '|' >>= \case 316 | [(Variable name, body)] -> return $ Lambda name body 317 | alts -> return $ Lambda "x" $ Case "x" alts 318 | 319 | -- | Two expressions joined by a binary operator. 320 | pBinary :: Parser Expr 321 | pBinary = pApply `chainl1` fmap (flip binary) symbol 322 | 323 | ------------------------------------------------------------------------------ 324 | -- * Types 325 | ------------------------------------------------------------------------------ 326 | 327 | -- | The top-level type parser. 328 | pType :: Parser Type 329 | pType = pTFunction 330 | 331 | -- | One type applied to another. 332 | pTApply :: Parser Type 333 | pTApply = pTTerm `chainl1` (pure TApply) 334 | 335 | -- | A type term. 336 | pTTerm :: Parser Type 337 | pTTerm = lexeme $ pTConst <|> pTVar <|> pTParens where 338 | pTVar = TVar <$> identifier 339 | pTConst = TConst <$> notKeyword upperIdent 340 | 341 | -- | A type wrapped in parentheses. Also how tuples and record types are 342 | -- written. 343 | pTParens :: Parser Type 344 | pTParens = between (schar '(') (schar ')') getTypes where 345 | getTypes = do 346 | bareTypes <- getBareTypes 347 | keyVals <- getKeyVals 348 | rest <- optionMaybe $ keysymbol "|" *> identifier 349 | case (bareTypes, keyVals) of 350 | ([(_, t)], []) | rest == Nothing -> return t 351 | (ts, kvs) -> return $ TRecord (H.fromList $ ts <> kvs) rest 352 | getBareTypes' = bareType `sepEndBy` schar ',' 353 | getBareTypes = zip (map render [0 :: Int ..]) <$> getBareTypes' 354 | bareType = try $ pType <* notFollowedBy (keysymbol ":") 355 | getKeyVals = keyVal `sepEndBy` schar ',' 356 | keyVal = (,) <$> identifier <*> (keysymbol ":" *> pType) 357 | 358 | -- | A function type. 359 | pTFunction :: Parser Type 360 | pTFunction = chainr1 pTApply (keysymbol "->" *> pure (==>)) 361 | 362 | ------------------------------------------------------------------------------ 363 | -- * Running the parser 364 | ------------------------------------------------------------------------------ 365 | 366 | -- | Parse a string as an expression, or return an error. 367 | parseIt :: String -> Either ParseError Expr 368 | parseIt = parse (pExpr <* eof) 369 | 370 | -- | Parse a string as a type, or return an error. 371 | parseType :: String -> Either ParseError Type 372 | parseType = parse (pType <* eof) 373 | 374 | parseInterp :: String -> Either ParseError Interp 375 | parseInterp = parse pInterp 376 | 377 | parse :: Parser a -> String -> Either ParseError a 378 | parse p = Parsec.parse p "" 379 | -------------------------------------------------------------------------------- /src/Language/Rowling/TypeCheck/Builtins.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | module Language.Rowling.TypeCheck.Builtins ( 4 | builtInTypes 5 | ) where 6 | 7 | import Language.Rowling.Common 8 | import Language.Rowling.Definitions.Types 9 | import qualified Data.Set as S 10 | 11 | builtInTypes :: TypeMap 12 | builtInTypes = [("+", "Int" ==> "Int" ==> "Int"), 13 | ("Some", poly ["a"] $ "a" ==> TApply "Maybe" "a"), 14 | ("None", poly ["a"] $ TApply "Maybe" "a")] 15 | where poly names t = Polytype (S.fromList names) t 16 | -------------------------------------------------------------------------------- /src/Language/Rowling/TypeCheck/TypeChecker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, LambdaCase, FlexibleContexts, 2 | TypeSynonymInstances, MultiParamTypeClasses, 3 | OverloadedLists, TypeFamilies, 4 | FunctionalDependencies, FlexibleInstances #-} 5 | module Language.Rowling.TypeCheck.TypeChecker ( 6 | module Language.Rowling.Definitions.Types, 7 | typeIt, typeIt', typeOfPattern, typeWithContext, typeExpr, typeExprN, 8 | pTypeIt, typeWithBindingsN 9 | ) where 10 | 11 | import qualified Prelude as P 12 | import qualified Data.HashMap.Strict as H 13 | import qualified Data.List as L 14 | import qualified Data.Set as S 15 | import qualified Data.Text as T 16 | import Data.ContextStack 17 | import System.IO.Unsafe 18 | 19 | import Language.Rowling.Common hiding (only) 20 | import Language.Rowling.Definitions.Expressions 21 | import Language.Rowling.Parser 22 | import Language.Rowling.Definitions.Types 23 | import Language.Rowling.TypeCheck.Builtins 24 | 25 | -- | The state of the type checker. 26 | data TCState = TCState { 27 | _count :: Int, -- ^ For generating new names. 28 | _typeMaps :: [TypeMap], -- ^ Maps names to types. 29 | _typeAliases :: AliasMap -- ^ Stores type aliases. 30 | } deriving (Show) 31 | 32 | -- | The TCState is a stack, where the frames are type maps. 33 | instance Stack TCState where 34 | type Frame TCState = TypeMap 35 | push tmap state = state {_typeMaps = push tmap $ _typeMaps state} 36 | pop state = (top, state {_typeMaps=rest}) where 37 | top:rest = _typeMaps state 38 | asList = _typeMaps 39 | modifyTop func state = state {_typeMaps=func top : rest} where 40 | top:rest = _typeMaps state 41 | 42 | -- The default type checker state contains the built-in type map. 43 | instance Default TCState where 44 | def = TCState { 45 | _count=0, 46 | _typeMaps=[builtInTypes], 47 | _typeAliases=def 48 | } 49 | 50 | -- | The main type checking monad, containing the type checker state. 51 | type TypeChecker = ExceptT EList (StateT TCState IO) 52 | 53 | ------------------------------------------------------------------------------ 54 | -- * Substitutions 55 | ------------------------------------------------------------------------------ 56 | 57 | -- | A mapping from (type variable) names to BaseTypes. 58 | newtype Substitution = Substitution (HashMap Name Type) deriving (Show, Eq) 59 | 60 | -- | Substitutions render as @{name => type}@. 61 | instance Render Substitution where 62 | render (Substitution s) = "{" <> T.intercalate ", " items <> "}" where 63 | items = fmap (\(f,t) -> render f <> "=>" <> render t) $ H.toList s 64 | 65 | -- | A class for things to which a substitution can be applied. 66 | class Substitutable a where (•>) :: Substitution -> a -> a 67 | 68 | -- | A substitution applied to a type replaces all variables in the type that 69 | -- appear in the substitution. 70 | instance Substitutable Type where 71 | subs@(Substitution s) •> t = case t of 72 | TVar n | H.member n s -> s H.! n 73 | TRecord fields Nothing -> TRecord (fmap (subs •>) fields) Nothing 74 | TRecord fields (Just r) -> case lookup r s of 75 | Nothing -> TRecord (fmap (subs •>) fields) (Just r) 76 | Just (TRecord fields' r') -> TRecord (fields' <> fields) r' 77 | Just _ -> P.error "Not a row type" 78 | TApply t1 t2 -> TApply (subs •> t1) (subs •> t2) 79 | _ -> t 80 | 81 | -- | Similar to a substitution, but first we remove all of the variables 82 | -- that are bound in the polytype. 83 | instance Substitutable Polytype where 84 | subs •> (Polytype vars t) = (Polytype vars (subs' •> t)) where 85 | subs' = S.foldr' remove subs vars 86 | 87 | -- | When substituting into a tuple, just apply the substitutions to both. 88 | instance (Substitutable a, Substitutable b) => Substitutable (a, b) where 89 | subs •> (a, b) = (subs •> a, subs •> b) 90 | 91 | -- | Apply the substitutions to all values. 92 | instance (Substitutable val) => Substitutable (HashMap key val) where 93 | subs •> m = fmap (subs •>) m 94 | 95 | -- | Apply the substitution to each member of the list. 96 | instance Substitutable a => Substitutable [a] where 97 | subs •> list = fmap (subs •>) list 98 | 99 | -- | Composes two substitutions. The newer substitution should go second. 100 | (•) :: Substitution -> Substitution -> Substitution 101 | Substitution s1 • Substitution s2 = Substitution (s1' <> s2) where 102 | s1' = fmap (Substitution s2 •>) s1 103 | 104 | -- | Composes a list of substitutions. 105 | compose :: [Substitution] -> Substitution 106 | compose = foldl' (•) noSubs 107 | 108 | -- | A singleton substitution. 109 | oneSub :: Name -> Type -> Substitution 110 | oneSub n = Substitution . H.singleton n 111 | 112 | -- | Removes a name from a substitution. 113 | remove :: Name -> Substitution -> Substitution 114 | remove n (Substitution s) = Substitution (H.delete n s) 115 | 116 | -- | An empty substitution. 117 | noSubs :: Substitution 118 | noSubs = Substitution mempty 119 | 120 | -- | Applies a substitution to the environment in the monad. 121 | substituteEnv :: Substitution -> TypeChecker () 122 | substituteEnv subs = do 123 | modify $ \s -> s {_typeMaps = subs •> _typeMaps s} 124 | 125 | ------------------------------------------------------------------------------ 126 | -- * Instantiation and Generalization 127 | ------------------------------------------------------------------------------ 128 | 129 | -- | Replaces all quanified variables in the polytype with fresh variables. 130 | instantiate :: Polytype -> TypeChecker Type 131 | instantiate (Polytype vars t) = do 132 | -- Make a substitution from all variables owned by this polytype 133 | sub <- fmap compose $ forM (S.toList vars) $ \v -> oneSub v <$> newvar 134 | -- Apply the subtitution to the owned type 135 | return $ sub •> t 136 | 137 | -- | Find which variables in the type are completely "owned" by the type 138 | -- (i.e., are not found in the surrounding environment) and creates a polytype 139 | -- with all of those variables quantified. 140 | generalize :: Type -> TypeChecker Polytype 141 | generalize t = do freeFromEnv <- freevars . _typeMaps <$> get 142 | return $ Polytype (freevars t \\ freeFromEnv) t 143 | 144 | ------------------------------------------------------------------------------ 145 | -- * Unification 146 | ------------------------------------------------------------------------------ 147 | 148 | -- | Given two types, produces a substitution which if applied would make the 149 | -- two types equal. Throws an error if such a substitution is impossible. 150 | unify :: Type -> Type -> TypeChecker Substitution 151 | unify t1 t2 = case (t1, t2) of 152 | (TVar a, _) -> return (Substitution (H.singleton a t2)) 153 | (_, TVar a) -> return (Substitution (H.singleton a t1)) 154 | (TConst n1, TConst n2) | n1 == n2 -> return noSubs 155 | (TApply a1 a2, TApply b1 b2) -> do 156 | s1 <- unify a1 b1 157 | s2 <- unify (s1 •> a2) (s1 •> b2) 158 | return (s1 • s2) 159 | (TRecord f1 r1, TRecord f2 r2) -> unifyRows (f1, r1) (f2, r2) 160 | (_, _) -> throwErrorC ["Can't unify types ", render t1, " and ", render t2] 161 | 162 | -- | Unifies the fields and "rest" of two row types. 163 | unifyRows :: (HashMap Name Type, Maybe Name) 164 | -> (HashMap Name Type, Maybe Name) 165 | -> TypeChecker Substitution 166 | unifyRows (f1, r1) (f2, r2) = do 167 | let presentInBoth = keys f1 `L.intersect` keys f2 168 | pSubs <- fmap compose $ forM presentInBoth $ \field -> 169 | unify (f1 ! field) (f2 ! field) 170 | subsR <- getAbsent (keys f1 L.\\ presentInBoth) r2 171 | subsL <- getAbsent (keys f2 L.\\ presentInBoth) r1 172 | return $ pSubs • subsR • subsL 173 | where 174 | getAbsent :: [Name] -> Maybe Name -> TypeChecker Substitution 175 | getAbsent absent rest = if L.null absent then return noSubs else 176 | case rest of 177 | Nothing -> throwErrorC ["Missing fields ", render absent] 178 | Just name -> do TVar rest' <- newvar 179 | let fields = H.fromList [(k, f1 ! k) | k <- absent] 180 | return (oneSub name $ TRecord fields $ Just rest') 181 | 182 | -- | Unifies all of the types in a list. 183 | unifyAll :: [Type] -> TypeChecker Substitution 184 | unifyAll [] = return noSubs 185 | unifyAll [t] = return noSubs 186 | unifyAll (t1:t2:ts) = do s <- unify t1 t2 187 | s' <- unifyAll (t2:ts) 188 | return (s • s') 189 | 190 | ------------------------------------------------------------------------------ 191 | -- * Type Inferrence Functions 192 | ------------------------------------------------------------------------------ 193 | 194 | -- ** Main Type Inferrence Function 195 | 196 | -- | Infers the type of an expression. Mostly follows Algorithm W. 197 | typeOf :: Expr -> TypeChecker (Type, Substitution) 198 | typeOf expr = go expr `catchError` whenTyping where 199 | go = \case 200 | Int _ -> only "Int" 201 | Float _ -> only "Float" 202 | Constructor "True" -> only "Bool" 203 | Constructor "False" -> only "Bool" 204 | String _ -> only "String" 205 | Constructor c -> find >>= instantiate >>= only where 206 | find = findOrError (oneErrorC ["Unknown constructor ", tshow c]) c 207 | Variable name -> find name >>= instantiate >>= only where 208 | find = findOrError $ oneErrorC ["No variable '" <> name <> "' in scope"] 209 | Lambda name body -> withFrame mempty $ do 210 | paramT <- newvar 211 | store name $ polytype paramT 212 | (bodyT, bodyS) <- typeOf body 213 | applyAndReturn (paramT ==> bodyT) bodyS 214 | Apply e1 e2 -> do 215 | (t1, s1) <- typeOf' e1 216 | (t2, s2) <- typeOf e2 217 | resultT <- newvar 218 | s3 <- unify t1 (t2 ==> resultT) `catchError` addErrorC 219 | [renderTicks e1, " has type ", renderTicks $ s1 • s2 •> t1, " and ", 220 | renderTicks e2, " has type ", renderTicks $ s1 • s2 •> t2] 221 | applyAndReturn resultT (s1 • s2 • s3) 222 | Let name e1 e2 -> do 223 | (t1, s1) <- typeOf' e1 224 | pt <- generalize t1 225 | withBindings ([(name, pt)] :: [(Name, Polytype)]) $ typeOf e2 226 | Dot expr field -> do 227 | (t, s) <- typeOf expr 228 | (t', s') <- deref t field 229 | applyAndReturn t' (s • s') 230 | Record fields -> do 231 | (ts, subs) <- typeOfPairList typeOf $ H.toList fields 232 | return (TRecord (H.fromList ts) Nothing, subs) 233 | Typed expr typ -> do 234 | (t, s) <- typeOf expr 235 | s' <- unify t typ 236 | applyAndReturn t (s • s') 237 | List list -> typeOfList typeOf $ toList list 238 | Case test alts -> do 239 | (testT, s1) <- typeOf test 240 | (resultT, resultS) <- typeOfAlts (s1 •> testT) alts 241 | applyAndReturn resultT (s1 • resultS) 242 | e -> errorC ["Cannot type the expression ", renderTicks e] 243 | whenTyping = addErrorC ["When typing the expression `", render expr, "`"] 244 | 245 | -- ** Type checkers specialized for certain scenarios 246 | -- Many of these functions take a function as an argument; this is so that 247 | -- they can be used for various different type checking functions. 248 | 249 | -- | Gets the type of a list of alternatives (pairs of pattern -> result). The 250 | -- list must not be empty, and the types of all patterns and all results must 251 | -- match each other (or at least be able to be unified with each other). 252 | typeOfAlts :: Type -- ^ The type that each pattern should have. 253 | -> [(Pattern, Expr)] -- ^ The alternatives list. 254 | -> TypeChecker (Type, Substitution) -- ^ The result type and all 255 | -- collected substitutions. 256 | typeOfAlts testT [] = throwError1 "No alternatives in case expression" 257 | typeOfAlts testT ((pattern, result):rest) = do 258 | ((resultType, patternType), subs) <- withFrame empty $ do 259 | (patternT, patternS) <- typeOfPattern pattern 260 | unifyS <- unify patternT testT 261 | (resultT, resultS) <- typeOf result 262 | applyAndReturn (resultT, patternT) (patternS • unifyS • resultS) 263 | case rest of 264 | [] -> return (resultType, subs) 265 | _ -> do (resultType', subs') <- typeOfAlts patternType rest 266 | unifyS <- unify resultType (subs •> resultType') 267 | applyAndReturn resultType (subs • subs') 268 | 269 | -- | Gets the types of all expressions in a list of @(Name, Expr)@ tuples. 270 | typeOfPairList :: (Expr -> TypeChecker (Type, Substitution)) 271 | -> [(Name, Expr)] -> TypeChecker ([(Name, Type)], Substitution) 272 | typeOfPairList typeOf = go noSubs where 273 | go subs [] = return ([], subs) 274 | go subs ((name, expr):others) = do 275 | substituteEnv subs 276 | (t, s) <- typeOf expr 277 | (ts, s') <- go (subs • s) others 278 | return ((name, t) : ts, subs • s • s') 279 | 280 | -- | Gets the types of all expressions in a list. The types do not need to be 281 | -- the same. 282 | typesInList :: (Expr -> TypeChecker (Type, Substitution)) 283 | -> [Expr] -> TypeChecker ([Type], Substitution) 284 | typesInList typeOf = go noSubs where 285 | go subs [] = return ([], subs) 286 | go subs (expr:others) = do 287 | substituteEnv subs 288 | (t, s) <- typeOf expr 289 | (ts, s') <- go (subs • s) others 290 | return (t : ts, subs • s • s') 291 | 292 | -- | Gets the type of expressions in a list. All of these types must be equal. 293 | typeOfList :: (Expr -> TypeChecker (Type, Substitution)) 294 | -> [Expr] -> TypeChecker (Type, Substitution) 295 | typeOfList typeOf exprs = do 296 | -- Start off with a list of a generic type. 297 | res <- newvar 298 | -- Get all the types in the list, and then unify them all. 299 | typesInList typeOf exprs >>= go res where 300 | go result ([], subs) = applyAndReturn (TApply "List" result) subs 301 | go result ((t:ts), subs) = do 302 | subs' <- unify t result 303 | go (subs • subs' •> result) (ts, subs • subs') 304 | 305 | -- | Loads new bindings from a pattern. So a variable doesn't get looked up; 306 | -- rather it gets added as a new variable to the scope. 307 | typeOfPattern :: Pattern -> TypeChecker (Type, Substitution) 308 | typeOfPattern pattern = case pattern of 309 | -- Constant patterns are valid, and don't generate any bindings. 310 | Int _ -> only "Int" 311 | Float _ -> only "Float" 312 | Constructor "True" -> only "Bool" 313 | Constructor "False" -> only "Bool" 314 | String _ -> only "String" 315 | -- With a variable, we assign it a fresh type. 316 | Variable name -> do var <- newvar 317 | store name $ polytype var 318 | only var 319 | -- The "rest" variable of a field gets instantiated here. 320 | Record fields -> do 321 | TVar rest <- newvar 322 | (fieldTypes, subs) <- runStateT (mapM go fields) noSubs 323 | return (TRecord fieldTypes (Just rest), subs) 324 | where go :: Pattern -> StateT Substitution TypeChecker Type 325 | go expr = do 326 | (t, subs) <- lift $ typeOfPattern expr 327 | modify (subs •) 328 | return t 329 | -- Typed patterns let us assert that the pattern follows a particular type. 330 | Typed expr t -> do (t', s) <- typeOfPattern expr `ifErrorDo` invalid 331 | s' <- unify t' t 332 | applyAndReturn t (s • s') 333 | -- Lists can appear in patterns. 334 | List patterns -> typeOfList typeOfPattern (toList patterns) 335 | -- Any other valid pattern will be a constructed expression, built from 336 | -- applying some constructor to 0 or more arguments. We can separate these 337 | -- out by calling `unroll`. 338 | _ -> case unroll pattern of 339 | (Constructor c, args) -> do 340 | let find = findOrError $ oneErrorC ["Unknown constructor ", tshow c] 341 | constructorT <- instantiate =<< find c 342 | constructedT <- newvar 343 | (argTs, argSubs) <- typesInList typeOfPattern args 344 | unifySubs <- unify constructorT (foldr (==>) constructedT argTs) 345 | applyAndReturn constructedT (argSubs • unifySubs) 346 | _ -> invalid 347 | where invalid = throwErrorC ["Invalid pattern: ", render pattern] 348 | 349 | 350 | -- ** Helper functions 351 | 352 | 353 | -- | Gets the type and applies the substitutions to the environment in one go. 354 | typeOf' :: Expr -> TypeChecker (Type, Substitution) 355 | typeOf' expr = typeOf expr >>= \(t, s) -> substituteEnv s >> return (t, s) 356 | 357 | -- | Produces a fresh type variable. 358 | newvar :: TypeChecker Type 359 | newvar = do i <- gets _count 360 | modify $ \s -> s {_count = i + 1} 361 | return $ TVar $ "$t" <> render i 362 | 363 | -- | Applies its second argument to its first, and then returns both. 364 | applyAndReturn :: Substitutable a 365 | => a -> Substitution -> TypeChecker (a, Substitution) 366 | applyAndReturn t s = return (s •> t, s) 367 | 368 | -- | Shortcut for returning a type with no substitutions. 369 | only :: Type -> TypeChecker (Type, Substitution) 370 | only t = return (t, noSubs) 371 | 372 | -- | Resolves a type alias. 373 | resolveAlias :: Name -> TypeChecker (Maybe Type) 374 | resolveAlias alias = lookup alias <$> gets _typeAliases 375 | 376 | -- | Looks up a field in a type. 377 | deref :: Type -> Name -> TypeChecker (Type, Substitution) 378 | deref t field = case t of 379 | TRecord fields rest -> case (lookup field fields, rest) of 380 | (Just t', _) -> return (t', noSubs) 381 | (Nothing, Just rest) -> do 382 | (var, TVar rest') <- tuple newvar newvar 383 | return (var, oneSub rest $ TRecord (H.singleton field var) (Just rest')) 384 | (Nothing, Nothing) -> noFieldErr 385 | TVar name -> do 386 | (var, TVar rest) <- tuple newvar newvar 387 | return (var, oneSub name $ TRecord (H.singleton field var) (Just rest)) 388 | TConst name -> resolveAlias name >>= \case 389 | Just t' -> deref t' field `ifErrorDo` noFieldErr 390 | Nothing -> noFieldErr 391 | _ -> noFieldErr 392 | where 393 | noFieldErr = throwErrorC ["Type ", render t, " has no field ", 394 | render field] 395 | 396 | ------------------------------------------------------------------------------ 397 | -- * Monadic functions 398 | ------------------------------------------------------------------------------ 399 | 400 | -- | Runs the type checking monad with a default state. 401 | runTyping :: TypeChecker a -> Either EList a 402 | runTyping = fst . runTypingWith def 403 | 404 | -- | Runs the type checking monad with a given state. 405 | runTypingWith :: TCState -> TypeChecker a -> (Either EList a, TCState) 406 | runTypingWith state action = do 407 | unsafePerformIO $ runStateT (runExceptT action) state 408 | 409 | -- | Get the type of an expression, or error. 410 | typeExpr :: Expr -> Either EList Type 411 | typeExpr = typeWithBindings empty 412 | 413 | -- | Get the type of an expression, normalized, or error. 414 | typeExprN :: Expr -> Either EList Type 415 | typeExprN = fmap normalize . typeExpr 416 | 417 | -- | Get the type of an expression with some environment, or error. 418 | typeWithBindings :: TypeMap -> Expr -> Either EList Type 419 | typeWithBindings bindings expr = do 420 | let state = def {_typeMaps = [bindings, builtInTypes]} 421 | case fst $ runTypingWith state $ typeOf expr of 422 | Right (t, s) -> return $ s •> t 423 | Left err -> Left err 424 | 425 | -- | Get the type of an expression with some environment, normalized, or 426 | -- error. 427 | typeWithBindingsN :: TypeMap -> Expr -> Either EList Type 428 | typeWithBindingsN bindings = fmap normalize . typeWithBindings bindings 429 | 430 | -- | Parses a string and gets its type. 431 | typeIt :: P.String -> (Either EList (Type, Substitution), TCState) 432 | typeIt = typeIt' typeOf 433 | 434 | -- | Parses a string and runs it into an arbitrary typechecker function. 435 | typeIt' :: (Expr -> TypeChecker a) 436 | -> P.String -> (Either EList a, TCState) 437 | typeIt' typer input = case parseIt input of 438 | Left err -> (Left $ oneError (pack $ show err), def) 439 | Right expr -> runTypingWith def $ typer expr 440 | 441 | -- | Runs the type checker with an initial state. 442 | typeWith :: MonadError EList m 443 | => TCState -> Expr -> m (Type, TCState) 444 | typeWith state expr = case runTypingWith state (typeOf expr) of 445 | (Left el, _) -> throwError el 446 | (Right (t, subs), state') -> return (subs •> t, state') 447 | 448 | -- | Runs the type checker given type mappings and type aliases. 449 | typeWithContext :: (Functor m, MonadError EList m) 450 | => TypeMap -> AliasMap -> Expr -> m (Type, TypeMap) 451 | typeWithContext tmap amap expr = do 452 | let state = TCState {_count = 0, _typeMaps = [tmap], _typeAliases = amap} 453 | (t, state) <- typeWith state expr 454 | return (t, P.head $ _typeMaps state) 455 | 456 | -- | Types the expression in the string and prints it. 457 | pTypeIt :: P.String -> IO () 458 | pTypeIt input = case parseIt input of 459 | Left err -> error $ show err 460 | Right expr -> case typeExprN expr of 461 | Left errlist -> printErrors errlist 462 | Right type_ -> putStrLn $ render expr <> " : " <> render type_ 463 | -------------------------------------------------------------------------------- /test/Language/Rowling/EvaluatorSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE NoMonomorphismRestriction #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | module Language.Rowling.EvaluatorSpec (main, spec) where 8 | 9 | import SpecHelper 10 | import Language.Rowling.Definitions.Expressions 11 | import Language.Rowling.Definitions.Values 12 | import Language.Rowling.Evaluator 13 | 14 | main :: IO () 15 | main = hspec spec 16 | 17 | 18 | -- Some useful functions for tests 19 | idfunc, singlelist, capturingFunc, apply, weird :: Expr 20 | idfunc = Lambda "x" "x" 21 | singlelist = Lambda "x" ["x"] 22 | capturingFunc = Let "x" (Int 3) (Lambda "y" (Apply "y" "x")) 23 | apply = Lambda "x" $ Lambda "y" $ Apply "x" "y" 24 | weird = Lambda "x" $ Let "y" "x" $ Lambda "z" $ Apply "z" "y" 25 | 26 | spec :: Spec 27 | spec = describe "evaluation" $ do 28 | primitivesSpec 29 | 30 | describe "records" $ do 31 | it "should evaluate records" $ do 32 | let input = Record [("foo", Int 2), ("bar", Float 3)] 33 | output = VRecord [("foo", VInt 2), ("bar", VFloat 3)] 34 | evalExpr input `shouldBeM` output 35 | 36 | describe "if statements" $ do 37 | it "should evaluate if statements" $ do 38 | let input = If "False" (Int 1) (Int 2) 39 | output = VInt 2 40 | evalExpr input `shouldBeM` output 41 | 42 | lambdaSpec 43 | applicationSpec 44 | builtinSpec 45 | listsSpec 46 | caseSpec 47 | 48 | exampleEvaluations 49 | 50 | primitivesSpec :: Spec 51 | primitivesSpec = describe "primitives" $ do 52 | it "should evaluate primitives" $ do 53 | evalExpr (Int 3) `shouldBeM` VInt 3 54 | evalExpr (Float 3) `shouldBeM` VFloat 3 55 | evalExpr (String "hello") `shouldBeM` VString "hello" 56 | evalExpr "True" `shouldBeM` VBool True 57 | 58 | lambdaSpec :: Spec 59 | lambdaSpec = describe "lambdas" $ do 60 | it "should evaluate a lambda with no captures" $ do 61 | let input = idfunc 62 | output = VClosure [] "x" "x" 63 | evalExpr input `shouldBeM` output 64 | let input = singlelist 65 | output = VClosure [] "x" ["x"] 66 | evalExpr input `shouldBeM` output 67 | 68 | it "should evaluate a lambda with captures" $ do 69 | let input = capturingFunc 70 | output = VClosure [("x", VInt 3)] "y" (Apply "y" "x") 71 | evalExpr input `shouldBeM` output 72 | 73 | it "should evaluate nested lambdas" $ do 74 | let input1 = apply 75 | output1 = VClosure [] "x" (Lambda "y" $ Apply "x" "y") 76 | evalExpr input1 `shouldBeM` output1 77 | 78 | let input2 = weird 79 | output2 = VClosure [] "x" (Let "y" "x" $ Lambda "z" $ Apply "z" "y") 80 | evalExpr input2 `shouldBeM` output2 81 | 82 | applicationSpec :: Spec 83 | applicationSpec = describe "function application" $ do 84 | it "should evaluate an application" $ do 85 | let input = Apply idfunc $ Int 0 86 | output = VInt 0 87 | evalExpr input `shouldBeM` output 88 | 89 | it "should apply a nested lambda" $ do 90 | -- (λx -> λy -> x y) (λx -> x) 91 | let input = Apply apply idfunc 92 | output = VClosure [("x", VClosure [] "x" "x")] 93 | "y" 94 | (Apply "x" "y") 95 | evalExpr input `shouldBeM` output 96 | 97 | it "should apply that function and act like the id function" $ do 98 | let input = Apply (Apply apply idfunc) $ String "wazzap" 99 | output = VString "wazzap" 100 | evalExpr input `shouldBeM` output 101 | 102 | it "should build tagged unions" $ do 103 | let input = Apply (Apply "Pair" (Int 1)) (Int 2) 104 | output = VTagged "Pair" [VInt 1, VInt 2] 105 | evalExpr input `shouldBeM` output 106 | 107 | let input = Apply (Apply "Pair" (Apply "Just" (Int 1))) (Int 2) 108 | output = VTagged "Pair" [VTagged "Just" [VInt 1], VInt 2] 109 | evalExpr input `shouldBeM` output 110 | 111 | describe "records in functions" $ do 112 | it "should evaluate record arguments" $ do 113 | let func = Lambda "r" $ "r" `Dot` "foo" 114 | input = Apply func $ Record [("foo", Int 10)] 115 | output = VInt 10 116 | evalExpr input `shouldBeM` output 117 | 118 | it "should return records" $ do 119 | let func = Lambda "x" $ Record [("foo", "x"), ("bar", "x")] 120 | input1 = Int 10 121 | output1 = VRecord [("foo", VInt 10), ("bar", VInt 10)] 122 | input2 = Record [("baz", Int 10)] 123 | output2 = VRecord [("foo", VRecord [("baz", VInt 10)]), 124 | ("bar", VRecord [("baz", VInt 10)])] 125 | evalExpr (Apply func input1) `shouldBeM` output1 126 | evalExpr (Apply func input2) `shouldBeM` output2 127 | 128 | let func = Lambda "x" $ Record [("a", "x" `Dot` "b"), 129 | ("b", "x" `Dot` "a")] 130 | input = Record [("a", Int 1), ("b", Float 1)] 131 | output = VRecord [("b", VInt 1), ("a", VFloat 1)] 132 | evalExpr (Apply func input) `shouldBeM` output 133 | 134 | it "should evaluate records that contain functions" $ do 135 | let func = Lambda "r" $ Apply ("r" `Dot` "f") (Int 6) 136 | input = Apply func $ Record [("f", idfunc)] 137 | output = VInt 6 138 | evalExpr input `shouldBeM` output 139 | 140 | describe "lists in functions" $ do 141 | it "should produce a list" $ do 142 | let input = (Apply (Lambda "x" ["x"]) (Float 1)) 143 | output = [VFloat 1] 144 | evalExpr input `shouldBeM` output 145 | 146 | let input = (Apply (Lambda "x" ["x", "x"]) (Float 1)) 147 | output = [VFloat 1, VFloat 1] 148 | evalExpr input `shouldBeM` output 149 | 150 | let input = (Apply (Lambda "x" [Float 2, "x"]) (Float 1)) 151 | output = [VFloat 2, VFloat 1] 152 | evalExpr input `shouldBeM` output 153 | 154 | caseSpec :: Spec 155 | caseSpec = describe "case statements" $ do 156 | it "should match appropriately" $ do 157 | let input e = Case e [("x", "x")] 158 | let exprs :: [Expr] -- type sig for type inference 159 | exprs = [Int 1, Float 2, String "hey", binary (Int 1) "+" (Int 2)] 160 | forM_ exprs $ \e -> do 161 | v <- evalExpr e 162 | evalExpr (input e) `shouldBeM` v 163 | 164 | it "should destructure" $ do 165 | let case_ e = Case e [(Apply "Just" "x", binary "x" "+" (Int 1)), 166 | ("Nothing", Int 0)] 167 | evalExpr (case_ "Nothing") `shouldBeM` VInt 0 168 | evalExpr (case_ (Apply "Just" (Int 2))) `shouldBeM` VInt 3 169 | 170 | it "should error if nothing matches" $ do 171 | let emptyCase = Case (Int 1) [] 172 | evalExpr emptyCase `shouldThrow` anyException 173 | let noMatchCase = Case (Int 1) [(Int 2, Int 3)] 174 | evalExpr emptyCase `shouldThrow` anyException 175 | 176 | let case_ pattern z = Case z [(pattern, binary "x" "+" "y")] 177 | it "should destructure nested patterns on the right" $ do 178 | -- (λ(Foo x (Bar y)) -> x + y) (Foo 2 (Bar 1)) 179 | let pat = Apply (Apply "Foo" "x") (Apply "Bar" "y") 180 | input = case_ pat $ Apply (Apply "Foo" (Int 2)) (Apply "Bar" (Int 1)) 181 | evalExpr input `shouldBeM` VInt 3 182 | 183 | it "should destructure nested patterns on the left" $ do 184 | -- (λ(Foo (Bar x) y) -> x + y) (Foo (Bar 1) 3) 185 | let pat = Apply (Apply "Foo" (Apply "Bar" "x")) "y" 186 | input = case_ pat $ Apply (Apply "Foo" (Apply "Bar" (Int 1))) (Int 3) 187 | evalExpr input `shouldBeM` VInt 4 188 | 189 | it "should destructure lists" $ do 190 | let input = case_ ["x", "y"] [Int 1, Int 2] 191 | evalExpr input `shouldBeM` VInt 3 192 | 193 | it "should destructure records" $ do 194 | let expr = Record [("foo", Int 1), ("bar", Int 2)] 195 | input = case_ (Record [("foo", "x"), ("bar", "y")]) expr 196 | evalExpr input `shouldBeM` VInt 3 197 | 198 | builtinSpec :: Spec 199 | builtinSpec = describe "builtins" $ do 200 | let test l op r result = 201 | evalExpr (binary l op r) `shouldBeM` result 202 | 203 | describe "addition" $ do 204 | it "should do ints" $ do 205 | test (Int 10) "+" (Int 2) (VInt 12) 206 | 207 | it "should do floats" $ do 208 | test (Float 7) "+" (Float 3) (VFloat 10) 209 | 210 | it "should do floats with ints and vice versa" $ do 211 | test (Float 1) "+" (Float 2) (VFloat 3) 212 | test (Float 1.5) "+" (Int 2) (VFloat 3.5) 213 | test (Int 1) "+" (Float 2) (VFloat 3) 214 | 215 | describe "multiplication" $ do 216 | it "should do ints" $ do 217 | test (Int 1) "*" (Int 2) (VInt 2) 218 | test (Int (-10)) "*" (Int 2) (VInt (-20)) 219 | 220 | it "should do floats" $ do 221 | test (Float 1) "*" (Float 2) (VFloat 2) 222 | test (Float 1) "*" (Int 2) (VFloat 2) 223 | 224 | it "should do floats with ints and vice versa" $ do 225 | test (Float 1) "*" (Float 2) (VFloat 2) 226 | test (Float 1.5) "*" (Int 2) (VFloat 3) 227 | test (Int 1) "*" (Float 2) (VFloat 2) 228 | 229 | describe "division" $ do 230 | it "should do ints" $ do 231 | test (Int 10) "/" (Int 2) (VInt 5) 232 | 233 | it "should round ints down when not an int result" $ do 234 | test (Int 1) "/" (Int 2) (VInt 0) 235 | test (Int 7) "/" (Int 3) (VInt 2) 236 | 237 | it "should do floats" $ do 238 | test (Float 7) "/" (Float 3) (VFloat (7/3)) 239 | 240 | it "should do floats with ints and vice versa" $ do 241 | test (Float 1) "/" (Float 2) (VFloat 0.5) 242 | test (Float 1) "/" (Int 2) (VFloat 0.5) 243 | test (Int 1) "/" (Float 2) (VFloat 0.5) 244 | 245 | describe "comparison" $ do 246 | it "should do ints" $ do 247 | test (Int 10) ">" (Int 2) (VBool True) 248 | test (Int 10) ">=" (Int 2) (VBool True) 249 | test (Int 10) "<" (Int 2) (VBool False) 250 | test (Int 10) "<=" (Int 2) (VBool False) 251 | test (Int 10) "==" (Int 2) (VBool False) 252 | test (Int 10) "==" (Int 10) (VBool True) 253 | test (Int 10) "<=" (Int 10) (VBool True) 254 | test (Int 10) ">=" (Int 10) (VBool True) 255 | test (Int 10) "!=" (Int 10) (VBool False) 256 | 257 | it "should do floats" $ do 258 | test (Float 10) ">" (Float 2) (VBool True) 259 | test (Float 10) ">=" (Float 2) (VBool True) 260 | test (Float 10) "<" (Float 2) (VBool False) 261 | test (Float 10) "<=" (Float 2) (VBool False) 262 | test (Float 10) "==" (Float 2) (VBool False) 263 | test (Float 10) "==" (Float 10) (VBool True) 264 | test (Float 10) "<=" (Float 10) (VBool True) 265 | test (Float 10) ">=" (Float 10) (VBool True) 266 | test (Float 10) "!=" (Float 10) (VBool False) 267 | 268 | it "should do floats with ints and vice versa" $ do 269 | test (Int 10) ">" (Float 2) (VBool True) 270 | test (Float 10) ">=" (Int 2) (VBool True) 271 | test (Int 10) "<" (Float 2) (VBool False) 272 | test (Float 10) "<=" (Int 2) (VBool False) 273 | test (Int 10) "==" (Float 2) (VBool False) 274 | 275 | describe "boolean operations" $ do 276 | it "should negate a bool" $ do 277 | evalExpr (Apply "not" "True") `shouldBeM` VBool False 278 | evalExpr (Apply "not" "False") `shouldBeM` VBool True 279 | 280 | it "should AND bools" $ do 281 | evalExpr (binary "True" "&&" "False") `shouldBeM` VBool False 282 | evalExpr (binary "True" "&&" "True") `shouldBeM` VBool True 283 | evalExpr (binary "False" "&&" "True") `shouldBeM` VBool False 284 | evalExpr (binary "False" "&&" "False") `shouldBeM` VBool False 285 | 286 | it "should OR bools" $ do 287 | evalExpr (binary "True" "||" "False") `shouldBeM` VBool True 288 | evalExpr (binary "True" "||" "True") `shouldBeM` VBool True 289 | evalExpr (binary "False" "||" "True") `shouldBeM` VBool True 290 | evalExpr (binary "False" "||" "False") `shouldBeM` VBool False 291 | 292 | describe "map" $ do 293 | it "should apply a function to each element of a list" $ do 294 | let list = List ["True", "True", "False"] 295 | input = Apply (Apply "each" list) "not" 296 | output = VArray [VBool False, VBool False, VBool True] 297 | evalExpr input `shouldBeM` output 298 | 299 | listsSpec :: Spec 300 | listsSpec = describe "lists" $ do 301 | it "should evaluate lists" $ do 302 | let nums = [1..10] 303 | evalExpr (List $ map Int nums) `shouldBeM` VArray $ map VInt nums 304 | evalExpr (List $ map Float nums) `shouldBeM` VArray $ map VFloat nums 305 | let strs = ["hello", "hey", "hi"] 306 | evalExpr (List $ map String strs) `shouldBeM` 307 | VArray $ map VString strs 308 | 309 | exampleEvaluations :: Spec 310 | exampleEvaluations = describe "example evaluations" $ do 311 | describe "factorial" $ do 312 | it "should compute a factorial" $ do 313 | let fact = Lambda "n" $ If (binary "n" "<" (Int 1)) 314 | (Int 1) 315 | (binary "n" "*" $ 316 | Apply "fact" $ binary "n" "-" (Int 1)) 317 | factOf n = Let "fact" fact $ Apply "fact" n 318 | evalExpr (factOf (Int 5)) `shouldBeM` VInt 120 319 | evalExpr (factOf (Float 5)) `shouldBeM` VFloat 120 320 | evalExpr (factOf (Int 10)) `shouldBeM` VInt 3628800 321 | -------------------------------------------------------------------------------- /test/Language/Rowling/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module Language.Rowling.ParserSpec (main, spec) where 7 | 8 | import SpecHelper 9 | import Language.Rowling.Definitions.Expressions 10 | import Language.Rowling.Parser 11 | 12 | main :: IO () 13 | main = hspec spec 14 | 15 | spec :: Spec 16 | spec = describe "parsing" $ do 17 | primitivesSpec 18 | dotSpec 19 | lambdasSpec 20 | letSpec 21 | recordsSpec 22 | applicationSpec 23 | ifSpec 24 | binarySpec 25 | listsSpec 26 | 27 | primitivesSpec :: Spec 28 | primitivesSpec = describe "primitives" $ do 29 | it "should parse primitives" $ do 30 | parseIt "3" `shouldBeR` Int 3 31 | parseIt "3.5" `shouldBeR` Float 3.5 32 | parseIt "\"hello\"" `shouldBeR` String "hello" 33 | parseIt "True" `shouldBeR` Constructor "True" 34 | parseIt "Just" `shouldBeR` Constructor "Just" 35 | 36 | dotSpec :: Spec 37 | dotSpec = describe "dots" $ do 38 | it "should parse dots" $ do 39 | parseIt "a.foo" `shouldBeR` Dot "a" "foo" 40 | 41 | it "should parse more complex stuff with dots" $ do 42 | parseIt "(x + y).z" `shouldBeR` Dot (binary "x" "+" "y") "z" 43 | 44 | it "should associate dots to the left" $ do 45 | parseIt "a.b.c" `shouldBeR` Dot (Dot "a" "b") "c" 46 | 47 | lambdasSpec :: Spec 48 | lambdasSpec = describe "lambdas" $ do 49 | it "should parse a simple lambda" $ do 50 | parseIt "&x -> x" `shouldBeR` Lambda "x" "x" 51 | 52 | it "should parse a nested lambda" $ do 53 | let output = Lambda "x" $ Lambda "y" $ Apply "y" "x" 54 | parseIt "&x -> &y -> y x" `shouldBeR` output 55 | 56 | it "should parse a lambda with a let statement" $ do 57 | let output = Lambda "x" $ Let "y" "x" "y" 58 | parseIt "&x -> let y = x; y" `shouldBeR` output 59 | 60 | it "should parse a nested lambda with a let statement" $ do 61 | let output = Lambda "x" $ Let "y" "x" (Lambda "z" $ Apply "z" "y") 62 | parseIt "&x -> let y = x; &z -> z y" `shouldBeR` output 63 | 64 | it "should parse a lambda with a pattern" $ do 65 | let output = Lambda "x" $ Case "x" [(Int 1, Int 2)] 66 | parseIt "&1 -> 2" `shouldBeR` output 67 | 68 | letSpec :: Spec 69 | letSpec = describe "let statements" $ do 70 | it "should parse a let statement" $ do 71 | parseIt "let foo = 1; foo" `shouldBeR` Let "foo" (Int 1) "foo" 72 | 73 | it "should parse a nested let statement" $ do 74 | let output = Let "x" "y" $ Let "z" "w" $ Int 3 75 | parseIt "let x = y; let z = w; 3" `shouldBeR` output 76 | 77 | it "should parse function declarations" $ do 78 | let output = Let "f" (Lambda "x" (binary "x" "+" (Int 3))) "f" 79 | parseIt "let f x = x + 3; f" `shouldBeR` output 80 | 81 | it "should parse function declarations with multiple args" $ do 82 | let output = Let "f" (Lambda "x" (Lambda "y" (binary "x" "+" "y"))) "f" 83 | parseIt "let f x y = x + y; f" `shouldBeR` output 84 | 85 | it "should parse function declarations with patterns" $ do 86 | let output = Let "f" (Lambda "a" (Case "a" [(Int 1, Int 2)])) "f" 87 | parseIt "let f 1 = 2; f" `shouldBeR` output 88 | 89 | it "should parse function declarations with multiple patterns" $ do 90 | let body = Case "a" [(Int 1, Int 2), ("y", binary "y" "+" (Int 3))] 91 | let output = Let "f" (Lambda "a" body) "f" 92 | parseIt "let f 1 = 2 | f y = y + 3; f" `shouldBeR` output 93 | 94 | it "should parse function declarations with multiple args/patterns" $ do 95 | let input = "let f 1 2 = 0 | f x y = x + y; f" 96 | -- This desugars to: 97 | -- let f a b = if [a, b] is [1, 2] -> 0 | [x, y] -> [x + y]; f 98 | body = Case ["a", "b"] [([Int 1, Int 2], Int 0), 99 | (["x", "y"], binary "x" "+" "y")] 100 | output = Let "f" (Lambda "a" $ Lambda "b" body) "f" 101 | parseIt input `shouldBeR` output 102 | 103 | it "should parse symbol function declarations" $ do 104 | let input = "let x +-+ y = x * (y + x); 0" 105 | output = Let "+-+" (Lambda "x" $ Lambda "y" $ 106 | binary "x" "*" (binary "y" "+" "x")) (Int 0) 107 | parseIt input `shouldBeR` output 108 | 109 | it "should parse symbol function declarations with multiple patterns" $ do 110 | let input = "let 1 +-+ 0 = 1 | x +-+ y = x * y; 0" 111 | body = Case ["a", "b"] [([Int 1, Int 0], Int 1), 112 | (["x", "y"], binary "x" "*" "y")] 113 | output = Let "+-+" (Lambda "a" $ Lambda "b" body) (Int 0) 114 | parseIt input `shouldBeR` output 115 | 116 | it "should fail if the wrong function name is used" $ do 117 | let input = "let foo 0 = 1 | bar 1 = 2; baz" 118 | parseIt input `shouldHaveErr` "Expected function named \"foo\"" 119 | 120 | it "should fail if the wrong number of arguments is used" $ do 121 | let input = "let foo 0 = 1 | foo 1 2 = 3; baz" 122 | parseIt input `shouldHaveErr` "Wrong number of arguments, expected 1" 123 | 124 | it "should fail if adding patterns to function with all variables" $ do 125 | let input = "let foo x = 1 | foo y = 2; foo" 126 | parseIt input `shouldHaveErr` "unexpected" 127 | let input = "let foo = 1 | foo = 2; foo" 128 | parseIt input `shouldHaveErr` "unexpected" 129 | 130 | recordsSpec :: Spec 131 | recordsSpec = describe "records" $ do 132 | it "should parse records" $ do 133 | let record = Record [("foo", Int 2), ("bar", Float 3)] 134 | parseIt "(foo=2, bar=3.0)" `shouldBeR` record 135 | 136 | it "should parse tuples" $ do 137 | let tup = Record [("0", "foo"), ("1", "False")] 138 | parseIt "(foo, False)" `shouldBeR` tup 139 | 140 | it "should parse tuples mixed with records" $ do 141 | let rec = Record [("0", "a"), ("1", "b"), ("foo", "c")] 142 | parseIt "(a, b, foo=c)" `shouldBeR` rec 143 | 144 | applicationSpec :: Spec 145 | applicationSpec = describe "applications" $ do 146 | it "should parse an application with variables" $ do 147 | parseIt "x y" `shouldBeR` Apply "x" "y" 148 | 149 | it "should parse an application with constants" $ do 150 | parseIt "f True" `shouldBeR` Apply "f" "True" 151 | parseIt "x 1" `shouldBeR` Apply "x" (Int 1) 152 | 153 | it "should nest applications to the left" $ do 154 | parseIt "a b c" `shouldBeR` Apply (Apply "a" "b") "c" 155 | 156 | it "should be able to apply things in parentheses" $ do 157 | parseIt "(a b) c" `shouldBeR` Apply (Apply "a" "b") "c" 158 | parseIt "a (b c)" `shouldBeR` Apply "a" (Apply "b" "c") 159 | 160 | it "should be able to apply constructors" $ do 161 | parseIt "Just 7" `shouldBeR` Apply "Just" (Int 7) 162 | 163 | ifSpec :: Spec 164 | ifSpec = describe "if statements" $ do 165 | it "should parse if statements" $ do 166 | let output = If "False" (Int 1) (Int 2) 167 | parseIt "if False then 1 else 2" `shouldBeR` output 168 | 169 | it "should parse nested if statements" $ do 170 | let output = If "True" (If "False" "a" "b") "c" 171 | parseIt "if True then if False then a else b else c" `shouldBeR` output 172 | let output = If "True" "a" (If "False" "b" "c") 173 | parseIt "if True then a else if False then b else c" `shouldBeR` output 174 | let output = If (If "True" "a" "b") "c" "d" 175 | parseIt "if if True then a else b then c else d" `shouldBeR` output 176 | 177 | it "should parse cases statements" $ do 178 | let output = Case "x" [(Int 1, Float 2), (Int 2, Float 0)] 179 | parseIt "if x is 1 -> 2.0 | 2 -> 0.0" `shouldBeR` output 180 | 181 | let input = "if x * 3 is 5 -> 0 | Just 7 -> 1 | foo -> foo" 182 | output = Case (binary "x" "*" (Int 3)) [(Int 5, Int 0), 183 | (Apply "Just" (Int 7), Int 1), 184 | ("foo", "foo")] 185 | parseIt input `shouldBeR` output 186 | 187 | binarySpec :: Spec 188 | binarySpec = describe "binary operations" $ do 189 | let bin a b = binary a "+" b 190 | it "should do addition" $ do 191 | parseIt "a + b" `shouldBeR` bin "a" "b" 192 | it "should do nested addition" $ do 193 | parseIt "a + b + c" `shouldBeR` bin (bin "a" "b") "c" 194 | let bin a b = binary a "-" b 195 | it "should do subtraction" $ do 196 | parseIt "a - b" `shouldBeR` bin "a" "b" 197 | it "should do nested subtraction" $ do 198 | parseIt "a - b - c" `shouldBeR` bin (bin "a" "b") "c" 199 | it "should respect parentheses" $ do 200 | parseIt "a - (b - c)" `shouldBeR` bin "a" (bin "b" "c") 201 | 202 | it "should do weird custom binary operators" $ do 203 | parseIt "a +-+ b" `shouldBeR` binary "a" "+-+" "b" 204 | 205 | it "should not take key symbols as binary operators" $ do 206 | parseIt "a = b" `shouldHaveErr` "" 207 | 208 | listsSpec :: Spec 209 | listsSpec = describe "list literals" $ do 210 | it "should do list literals" $ do 211 | parseIt "[a, b, c]" `shouldBeR` ["a", "b", "c"] 212 | 213 | it "should do nested list literals" $ do 214 | parseIt "[a, [b, c], d]" `shouldBeR` ["a", ["b", "c"], "d"] 215 | -------------------------------------------------------------------------------- /test/Language/Rowling/TypeCheckerSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, OverloadedLists #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Language.Rowling.TypeCheckerSpec (spec) where 5 | 6 | import SpecHelper 7 | import ClassyPrelude hiding (assert) 8 | import Data.HashMap.Strict (HashMap) 9 | import qualified Data.HashMap.Strict as H 10 | import Language.Rowling.Definitions.Expressions 11 | import Language.Rowling.Definitions.Types 12 | import Language.Rowling.TypeCheck.TypeChecker 13 | 14 | -- | Shorthand for a repeatedly used function 15 | twith :: TypeMap -> Expr -> Either EList Type 16 | twith = typeWithBindingsN 17 | 18 | can'tUnify :: Either EList Type -> IO () 19 | can'tUnify x = x `shouldHaveErr` "Can't unify types" 20 | 21 | spec :: Spec 22 | spec = do 23 | describe "primitive types" $ do 24 | it "should get type of literals" $ do 25 | typeExpr (Int 0) `shouldBeR` "Int" 26 | typeExpr (Float 0) `shouldBeR` "Float" 27 | typeExpr (String "hey there") `shouldBeR` "String" 28 | typeExpr "True" `shouldBeR` "Bool" 29 | typeExpr "False" `shouldBeR` "Bool" 30 | 31 | describe "lists" $ do 32 | it "should type lists" $ do 33 | typeExpr [Int 0, Int 1] `shouldBeR` TApply "List" "Int" 34 | it "should fail if not all are same type" $ do 35 | can'tUnify (typeExpr [Int 0, Float 1]) 36 | 37 | describe "functions" $ do 38 | it "should type functions" $ do 39 | typeExprN (Lambda "x" "x") `shouldBeR` "a" ==> "a" 40 | typeExprN (Lambda "x" $ Lambda "y" $ Apply "y" "x") 41 | `shouldBeR` 42 | "a" ==> ("a" ==> "b") ==> "b" 43 | 44 | describe "applications" $ do 45 | it "should type applications" $ do 46 | typeExpr (Apply (Lambda "x" "x") (Int 1)) `shouldBeR` "Int" 47 | typeExpr (Apply (Lambda "x" "x") [Int 1]) 48 | `shouldBeR` TApply "List" "Int" 49 | typeExpr (Apply (Lambda "x" ["x"]) (Float 1)) 50 | `shouldBeR` TApply "List" "Float" 51 | 52 | describe "lets" $ do 53 | it "should type let statements" $ do 54 | typeExpr (Let "foo" (Int 1) "foo") `shouldBeR` "Int" 55 | typeExprN (Lambda "x" $ Let "y" "x" "y") `shouldBeR` "a" ==> "a" 56 | typeExprN (Lambda "x" $ Let "y" (Int 1) "y") `shouldBeR` "a" ==> "Int" 57 | typeExpr (Let "id" (Lambda "x" "x") (Apply "id" (Int 1))) 58 | `shouldBeR` "Int" 59 | 60 | describe "case statements" $ do 61 | it "should error if there are no alternatives" $ do 62 | twith [("x", "Int")] (Case "x" []) `shouldHaveErr` "No alternatives" 63 | 64 | it "should error if pattern types don't match test type" $ do 65 | let t = twith [("x", "Float")] 66 | can'tUnify (t (Case "x" [(Int 0, Int 1)])) 67 | can'tUnify (t (Case "x" [(Float 0, Int 1), (Int 1, Int 2)])) 68 | 69 | it "should error if result types don't match each other" $ do 70 | let t = twith [("x", "Int")] 71 | can'tUnify (t (Case "x" [(Int 0, Float 1), (Int 1, Int 0)])) 72 | 73 | it "should type simple case expressions" $ do 74 | let t = twith [("x", "Int")] 75 | t (Case "x" [(Int 0, Float 1)]) `shouldBeR` "Float" 76 | t (Case "x" [(Int 0, Float 1), (Int 1, Float 2)]) `shouldBeR` "Float" 77 | t (Case "x" [(Int 0, Int 1), ("q", "q")]) `shouldBeR` "Int" 78 | 79 | it "should handle records in case expressions" $ do 80 | -- This tests that the following typing holds: 81 | -- λ(x: 1, y: y) -> y.z : (x: Int, y: (z: a | b) | c) -> a 82 | let pat = Record [("x", Int 1), ("y", "y")] 83 | res = "y" `Dot` "z" 84 | trec1 = tRecord' [("z", "a")] "b" 85 | trec2 = tRecord' [("x", "Int"), ("y", trec1)] "c" 86 | let input = Lambda "q" $ Case "q" [(pat, res)] 87 | typeExprN input `shouldBeR` trec2 ==> "a" 88 | 89 | it "should type constructed expressions in case expressions" $ do 90 | let case_ = Case "x" [(Apply "Some" "y", binary "y" "+" (Int 1)), 91 | ("None", Int 0)] 92 | input = Lambda "x" $ case_ 93 | typeExpr input `shouldBeR` TApply "Maybe" "Int" ==> "Int" 94 | 95 | it "should handle list patterns" $ do 96 | let input = Lambda "x" $ Case "x" [([Int 1, Int 2], Int 3), 97 | (["y", "z"], binary "y" "+" "z")] 98 | output = TApply "List" "Int" ==> "Int" 99 | typeExpr input `shouldBeR` output 100 | 101 | describe "builtins" $ do 102 | describe "binary operators" $ do 103 | it "should type check addition" $ do 104 | typeExpr (binary (Int 1) "+" (Int 2)) `shouldBeR` "Int" 105 | 106 | describe "constructors" $ do 107 | it "should recognize maybes" $ do 108 | typeExprN "None" `shouldBeR` TApply "Maybe" "a" 109 | typeExpr (Apply "Some" (Int 1)) `shouldBeR` TApply "Maybe" "Int" 110 | -------------------------------------------------------------------------------- /test/Language/Rowling/TypeLibSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, OverloadedLists #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Language.Rowling.TypeLibSpec (spec) where 5 | 6 | import SpecHelper 7 | import Data.HashMap.Strict (HashMap) 8 | import qualified Data.HashMap.Strict as H 9 | import Language.Rowling.Definitions.Types 10 | 11 | spec :: Spec 12 | spec = do 13 | fromStringSpec 14 | normalizerSpec 15 | 16 | fromStringSpec :: Spec 17 | fromStringSpec = describe "fromstring" $ do 18 | it "should wrap captalized strings in TConst" $ do 19 | "Foo" `shouldBe` TConst "Foo" 20 | it "should wrap lower-case or $ strings in TVar" $ do 21 | "a" `shouldBe` TVar "a" 22 | "$t12" `shouldBe` TVar "$t12" 23 | it "should strip whitespace" $ do 24 | " Foo " `shouldBe` TConst "Foo" 25 | " bar" `shouldBe` TVar "bar" 26 | 27 | normalizerSpec :: Spec 28 | normalizerSpec = describe "type normalizer" $ do 29 | it "should replace single type variables" $ do 30 | normalize "$t8" `shouldBe` TVar "a" 31 | 32 | it "should replace type variables in functions" $ do 33 | normalize (TVar "$t1" ==> TVar "$t2") `shouldBe` (TVar "a" ==> TVar "b") 34 | 35 | it "should remember the names it made" $ do 36 | let recT = tRecord [("foo", TVar "$x"), ("bar", TVar "$x")] 37 | normalize recT `shouldBe` tRecord [("foo", TVar "a"), ("bar", TVar "a")] 38 | let funcT = TVar "$t1" ==> TVar "$t2" ==> TVar "$t1" 39 | normalize funcT `shouldBe` (TVar "a" ==> TVar "b" ==> TVar "a") 40 | 41 | it "should leave constants alone" $ do 42 | normalize "Bloop" `shouldBe` TConst "Bloop" 43 | normalize ("x" ==> "Bleep") `shouldBe` ("a" ==> TConst "Bleep") 44 | 45 | it "should normalize record types" $ do 46 | let t1 = tRecord [("foo", "$x")] 47 | t2 = TRecord [("bar", "$y")] (Just "$z") 48 | normalize t1 `shouldBe` tRecord [("foo", "a")] 49 | normalize t2 `shouldBe` TRecord [("bar", "a")] (Just "b") 50 | 51 | it "should update the state after making a replacement" $ do 52 | let t = TVar "x" 53 | (t', (name, mapping)) = runState (normalizeS t) ("a", mempty) 54 | t' `shouldBe` TVar "a" 55 | mapping `shouldBe` [("x", "a")] 56 | name `shouldBe` "b" 57 | 58 | it "should not have a problem if the variables start with 'a'" $ do 59 | normalize ("a" ==> "b" ==> "c") `shouldBe` ("a" ==> "b" ==> TVar "c") 60 | normalize ("c" ==> "a" ==> "b") `shouldBe` ("a" ==> "b" ==> TVar "c") 61 | 62 | -------------------------------------------------------------------------------- /test/Language/Rowling/ValuesSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | module Language.Rowling.ValuesSpec (main, spec) where 8 | 9 | import SpecHelper 10 | import Language.Rowling.Definitions.Expressions 11 | import Language.Rowling.Definitions.Values 12 | 13 | main :: IO () 14 | main = hspec $ spec >> spec 15 | 16 | spec :: Spec 17 | spec = patternMatchSpec 18 | 19 | patternMatchSpec :: Spec 20 | patternMatchSpec = describe "pattern matching" $ do 21 | it "should match literals that equal" $ do 22 | match (Int 1) (VInt 1) 23 | match (Float 1) (VFloat 1) 24 | match "False" (VBool False) 25 | match (String "wazzap") (VString "wazzap") 26 | 27 | it "should not match literals that are not equal" $ do 28 | noMatch (Int 1) (VInt 2) 29 | noMatch (Float 1) (VFloat 2) 30 | noMatch (String "hey") (VString "yo") 31 | 32 | it "should match variables" $ do 33 | let vals :: [Value] = [VInt 1, VFloat 1, VBool True, ["hello", "world"]] 34 | forM_ vals $ \val -> 35 | matchWith (Variable "x") val [("x", val)] 36 | 37 | it "should match list patterns" $ do 38 | match [Int 1, Int 2] [VInt 1, VInt 2] 39 | matchWith ["a", Int 1] [VInt 0, VInt 1] [("a", VInt 0)] 40 | noMatch ["a", Int 1] [VInt 0, VInt 2] 41 | 42 | describe "record patterns" $ do 43 | it "should match when keys match" $ do 44 | match (Record [("x", Int 1), ("y", Int 3)]) 45 | (VRecord [("x", VInt 1), ("y", VInt 3)]) 46 | matchWith (Record [("x", "a"), ("y", "b")]) 47 | (VRecord [("x", VInt 2), ("y", VFloat 5)]) 48 | [("a", VInt 2), ("b", VFloat 5)] 49 | 50 | it "should match when there are extra keys in the value" $ do 51 | match (Record [("x", Int 1), ("y", Int 3)]) 52 | (VRecord [("x", VInt 1), ("y", VInt 3), ("z", VInt 0)]) 53 | matchWith (Record [("x", "a"), ("y", "b")]) 54 | (VRecord [("x", VInt 2), ("y", VFloat 5), ("z", VInt 0)]) 55 | [("a", VInt 2), ("b", VFloat 5)] 56 | 57 | it "should NOT match when there are extra keys in the pattern" $ do 58 | noMatch (Record [("x", Int 1), ("y", Int 3)]) 59 | (VRecord [("x", VInt 2), ("y", VInt 3)]) 60 | noMatch (Record [("x", Int 1), ("y", Int 3)]) 61 | (VRecord [("x", VInt 2)]) 62 | 63 | describe "haskell builtins" $ do 64 | it "should use haskell booleans" $ do 65 | match "True" (VBool True) 66 | match "False" (VBool False) 67 | noMatch "False" (VBool True) 68 | noMatch "True" (VBool False) 69 | 70 | it "should use haskell maybes" $ do 71 | match "None" (VMaybe Nothing) 72 | match (Apply "Some" (Int 3)) (VMaybe (Just $ VInt 3)) 73 | noMatch "None" (VMaybe $ Just (VInt 0)) 74 | 75 | describe "compound expressions" $ do 76 | it "should match singleton constructors" $ do 77 | match "Foo" (VTagged "Foo" []) 78 | it "should match applied constructors" $ do 79 | match (Apply "Foo" (Int 1)) (VTagged "Foo" [VInt 1]) 80 | it "should assign variables correctly" $ do 81 | matchWith (Apply "Foo" "x") (VTagged "Foo" [VInt 1]) [("x", VInt 1)] 82 | it "should handle multiple variables" $ do 83 | matchWith (Apply (Apply "A" "b") "c") (VTagged "A" [VInt 1, VFloat 2]) 84 | [("b", VInt 1), ("c", VFloat 2)] 85 | it "should handle a mix of variables and constants" $ do 86 | matchWith (Apply (Apply "A" "b") (Int 1)) (VTagged "A" [VInt 1, VInt 1]) 87 | [("b", VInt 1)] 88 | it "should reject incompatible matches" $ do 89 | noMatch (Apply (Apply "A" "b") (Int 1)) (VTagged "A" [VInt 1, VInt 0]) 90 | it "should reject when the length isn't correct" $ do 91 | noMatch (Apply (Apply "A" "b") (Int 1)) (VTagged "A" [VInt 0]) 92 | it "should handle nested compound expressions" $ do 93 | -- Pattern: @A (B 1) x@. Value: @A (B 1) "hello"@ 94 | matchWith (Apply (Apply "A" (Apply "B" (Int 1))) "x") 95 | (VTagged "A" [VTagged "B" [VInt 1], VString "hello"]) 96 | [("x", VString "hello")] 97 | -- Pattern: @A (B 1) x@. Value: @A (B 2) "hello"@ 98 | noMatch (Apply (Apply "A" (Apply "B" (Int 1))) "x") 99 | (VTagged "A" [VTagged "B" [VInt 2], VString "hello"]) 100 | 101 | where 102 | matchWith :: Pattern -> Value -> HashMap Name Value -> IO () 103 | matchWith p v bs = patternMatch p v `shouldBeJ` bs 104 | match :: Pattern -> Value -> IO () 105 | match p v = matchWith p v [] 106 | noMatch :: Pattern -> Value -> IO () 107 | noMatch p v = shouldBeN $ patternMatch p v 108 | 109 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} -------------------------------------------------------------------------------- /test/SpecHelper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module SpecHelper 3 | ( module Test.Hspec 4 | , module Language.Rowling.Common 5 | , shouldBeM, shouldBeR, shouldHaveErr, shouldBeMR, shouldBeJ 6 | , shouldBeN 7 | ) where 8 | 9 | import Test.Hspec 10 | import Test.Hspec.Expectations.Contrib 11 | import Language.Rowling.Common 12 | 13 | -- | Runs `shouldBe` on the result of an IO action. 14 | shouldBeM :: (Show a, Eq a) => IO a -> a -> IO () 15 | shouldBeM action expected = do 16 | result <- action 17 | result `shouldBe` expected 18 | 19 | infixr 0 `shouldBeM` 20 | 21 | -- | Asserts that the first argument is a `Just` value equal to the second 22 | -- argument. 23 | shouldBeJ :: (Show a, Eq a) => Maybe a -> a -> IO () 24 | shouldBeJ x y = do 25 | shouldSatisfy x isJust 26 | let Just x' = x 27 | x' `shouldBe` y 28 | 29 | -- | Asserts that the argument is `Nothing`. 30 | shouldBeN :: (Show a) => Maybe a -> IO () 31 | shouldBeN = flip shouldSatisfy isNothing 32 | 33 | -- | Asserts that the first argument is a `Right` value equal to the second 34 | -- argument. 35 | shouldBeR :: (Show a, Show b, Eq b) => Either a b -> b -> IO () 36 | shouldBeR x y = do 37 | shouldSatisfy x isRight 38 | let Right x' = x 39 | x' `shouldBe` y 40 | 41 | infixr 0 `shouldBeR` 42 | 43 | -- | Asserts that the argument is a `Left` value, containing something which 44 | -- when `Show`n contains the provided substring. 45 | shouldHaveErr :: (Show a, Show b) 46 | => Either a b -- ^ Should be a `Left` value. 47 | -> String -- ^ Error should contain this. 48 | -> IO () 49 | shouldHaveErr x msg = do 50 | shouldSatisfy x isLeft 51 | let Left err = x 52 | show err `shouldSatisfy` isInfixOf msg 53 | 54 | -- | Runs `shouldBeR` on the result of an IO action. 55 | shouldBeMR :: (Show a, Show x, Eq a, Eq x) => IO (Either x a) -> a -> IO () 56 | shouldBeMR action expected = action >>= flip shouldBeR expected 57 | --------------------------------------------------------------------------------