├── .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 <nixpkgs> {}, 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 _) = "<BUILTIN " <> 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 | 


--------------------------------------------------------------------------------