├── stack.yaml
├── .gitignore
├── shell.nix
├── CHANGELOG.md
├── default.nix
├── src
    ├── Expresso
    │   ├── Pretty.hs
    │   ├── TH
    │   │   └── QQ.hs
    │   ├── Syntax.hs
    │   ├── Utils.hs
    │   ├── Type.hs
    │   ├── Eval.hs
    │   ├── Parser.hs
    │   └── TypeCheck.hs
    ├── Tests.hs
    ├── Expresso.hs
    └── Repl.hs
├── LICENSE
├── lib
    ├── Text.x
    ├── Prelude.x
    └── List.x
├── expresso.cabal
└── README.md


/stack.yaml:
--------------------------------------------------------------------------------
1 | resolver: lts-9.14
2 | packages:
3 | - '.'
4 | extra-deps: []
5 | flags: {}
6 | extra-package-dbs: []
7 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | dist/
2 | 
3 | # Cabal new-style artifacts
4 | dist-newstyle/
5 | cabal.project.local
6 | .ghc.environment.*
7 | 


--------------------------------------------------------------------------------
/shell.nix:
--------------------------------------------------------------------------------
1 | let nixpkgs = import <nixpkgs> {};
2 |     orig = nixpkgs.pkgs.haskellPackages.callPackage ./default.nix {};
3 | in (nixpkgs.pkgs.haskell.lib.doBenchmark orig).env
4 | 


--------------------------------------------------------------------------------
/CHANGELOG.md:
--------------------------------------------------------------------------------
 1 | # Change Log
 2 | 
 3 | ## 0.1.3.0
 4 | 
 5 | - Compilation with GHC 8.8.3
 6 | 
 7 | ## 0.1.2.0
 8 | 
 9 | - added type synonyms
10 | - let bindings can now be annotated with types
11 | - support field renaming during record matches
12 | - added a text append primitive
13 | - added a list uncons primitive
14 | - added example List and Text library modules
15 | 
16 | ## 0.1.1.0
17 | 
18 | - API convenience functions for building record/variant HasValue instances.
19 | - HasValue instances for function types.
20 | - added Type constructors and pattern synonyms to API
21 | - terminfo as an explicit dependency.
22 | 
23 | ## 0.1.0.2
24 | 
25 | Expresso REPL fails to build on Hackage, disable building for now.
26 | 
27 | ## 0.1.0.1
28 | 
29 | Cabal file dependency bounds changed for GHC 8.6 compatibility.
30 | 
31 | ## 0.1.0.0
32 | 
33 | Initial release.
34 | 


--------------------------------------------------------------------------------
/default.nix:
--------------------------------------------------------------------------------
 1 | { mkDerivation, base, containers, directory, filepath, hashable
 2 | , haskeline, mtl, parsec, stdenv, tasty, tasty-hunit
 3 | , template-haskell, terminfo, text, unordered-containers, wl-pprint
 4 | }:
 5 | mkDerivation {
 6 |   pname = "expresso";
 7 |   version = "0.1.1.0";
 8 |   src = ./.;
 9 |   isLibrary = true;
10 |   isExecutable = true;
11 |   libraryHaskellDepends = [
12 |     base containers directory filepath hashable haskeline mtl parsec
13 |     template-haskell terminfo text unordered-containers wl-pprint
14 |   ];
15 |   executableHaskellDepends = [
16 |     base containers directory filepath hashable haskeline mtl parsec
17 |     terminfo text unordered-containers wl-pprint
18 |   ];
19 |   testHaskellDepends = [
20 |     base containers directory filepath hashable haskeline mtl parsec
21 |     tasty tasty-hunit terminfo text unordered-containers wl-pprint
22 |   ];
23 |   description = "A simple expressions language based on row types";
24 |   license = stdenv.lib.licenses.bsd3;
25 | }
26 | 


--------------------------------------------------------------------------------
/src/Expresso/Pretty.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | -- |
 4 | -- Module      : Expresso.Pretty
 5 | -- Copyright   : (c) Tim Williams 2017-2019
 6 | -- License     : BSD3
 7 | --
 8 | -- Maintainer  : info@timphilipwilliams.com
 9 | -- Stability   : experimental
10 | -- Portability : portable
11 | --
12 | -- Pretty printing utilities.
13 | --
14 | module Expresso.Pretty (
15 |       module Text.PrettyPrint.Leijen
16 |     , parensList
17 |     , bracketsList
18 |     , bracesList
19 |     , sepBy
20 |     , catBy
21 |     , render
22 |     ) where
23 | 
24 | import Data.String
25 | import Text.PrettyPrint.Leijen ( Doc, (<+>), (<//>), angles, braces, brackets
26 |                                , comma, dot, dquotes, empty, hcat, hsep, indent
27 |                                , int, integer, double, parens, space, text, string
28 |                                , squotes, vcat)
29 | import qualified Text.PrettyPrint.Leijen as PP
30 | 
31 | instance IsString Doc where
32 |   fromString = text
33 | 
34 | bracketsList :: [Doc] -> Doc
35 | bracketsList = brackets . hsep . PP.punctuate comma
36 | 
37 | parensList :: [Doc] -> Doc
38 | parensList = parens . hsep . PP.punctuate comma
39 | 
40 | bracesList :: [Doc] -> Doc
41 | bracesList = braces . hsep . PP.punctuate comma
42 | 
43 | sepBy :: Doc -> [Doc] -> Doc
44 | sepBy d = hsep . PP.punctuate d
45 | 
46 | catBy :: Doc -> [Doc] -> Doc
47 | catBy d = hcat . PP.punctuate d
48 | 
49 | render :: PP.Doc -> String
50 | render doc = PP.displayS (PP.renderPretty 0.8 100 doc) []
51 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Note: This license has also been called the "New BSD License" or "Modified BSD License". See also the 2-clause BSD License.
 2 | 
 3 | Copyright 2017-2019, Tim Philip Williams
 4 | 
 5 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
 6 | 
 7 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
 8 | 
 9 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
10 | 
11 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
12 | 
13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
14 | 


--------------------------------------------------------------------------------
/src/Expresso/TH/QQ.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TemplateHaskell #-}
 2 | {-# LANGUAGE QuasiQuotes #-}
 3 | 
 4 | -- |
 5 | -- Module      : Expresso.TH.QQ
 6 | -- Copyright   : (c) Tim Williams 2017-2019
 7 | -- License     : BSD3
 8 | --
 9 | -- Maintainer  : info@timphilipwilliams.com
10 | -- Stability   : experimental
11 | -- Portability : portable
12 | --
13 | -- Quasi-quoters for defining Expresso types in Haskell.
14 | --
15 | module Expresso.TH.QQ (expressoType, expressoTypeSyn) where
16 | 
17 | import Control.Exception
18 | 
19 | import Language.Haskell.TH (ExpQ, Loc(..), Q, location, runIO)
20 | import Language.Haskell.TH.Quote (QuasiQuoter(..), dataToExpQ)
21 | 
22 | import qualified Text.Parsec as P
23 | import qualified Text.Parsec.Pos as P
24 | import Text.Parsec.String
25 | 
26 | import Expresso.Parser
27 | 
28 | -- | Expresso Quasi-Quoter for type declarations.
29 | expressoType :: QuasiQuoter
30 | expressoType = def { quoteExp = genTypeAnn }
31 | 
32 | -- | Expresso Quasi-Quoter for type synonym declarations.
33 | expressoTypeSyn :: QuasiQuoter
34 | expressoTypeSyn = def { quoteExp = genTypeSynDecl }
35 | 
36 | def :: QuasiQuoter
37 | def = QuasiQuoter
38 |     { quoteExp  = failure "expressions"
39 |     , quotePat  = failure "patterns"
40 |     , quoteType = failure "types"
41 |     , quoteDec  = failure "declarations"
42 |     }
43 |   where
44 |     failure kind =
45 |         error $ "This quasi-quoter does not support splicing " ++ kind
46 | 
47 | genTypeAnn :: String -> ExpQ
48 | genTypeAnn str = do
49 |     l <- location'
50 |     c <- runIO $ parseIO (P.setPosition l *> topLevel pTypeAnn) str
51 |     dataToExpQ (const Nothing) c
52 | 
53 | genTypeSynDecl :: String -> ExpQ
54 | genTypeSynDecl str = do
55 |     l <- location'
56 |     c <- runIO $ parseIO (P.setPosition l *> topLevel pSynonymDecl) str
57 |     dataToExpQ (const Nothing) c
58 | 
59 | -- | find the current location in the Haskell source file and convert it to parsec @SourcePos@.
60 | location' :: Q P.SourcePos
61 | location' = aux <$> location
62 |   where
63 |     aux :: Loc -> P.SourcePos
64 |     aux loc = uncurry (P.newPos (loc_filename loc)) (loc_start loc)
65 | 
66 | parseIO :: Parser a -> String -> IO a
67 | parseIO p str =
68 |   case P.parse p "" str of
69 |     Left err -> throwIO (userError (show err))
70 |     Right a  -> return a
71 | 


--------------------------------------------------------------------------------
/src/Expresso/Syntax.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveFunctor #-}
  2 | {-# LANGUAGE DeriveFoldable #-}
  3 | {-# LANGUAGE DeriveTraversable #-}
  4 | {-# LANGUAGE FlexibleInstances #-}
  5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  6 | {-# LANGUAGE TupleSections #-}
  7 | {-# LANGUAGE TypeOperators #-}
  8 | {-# LANGUAGE TypeSynonymInstances #-}
  9 | {-# LANGUAGE OverloadedStrings #-}
 10 | {-# LANGUAGE ScopedTypeVariables #-}
 11 | {-# LANGUAGE ViewPatterns #-}
 12 | 
 13 | -- |
 14 | -- Module      : Expresso.Syntax
 15 | -- Copyright   : (c) Tim Williams 2017-2019
 16 | -- License     : BSD3
 17 | --
 18 | -- Maintainer  : info@timphilipwilliams.com
 19 | -- Stability   : experimental
 20 | -- Portability : portable
 21 | --
 22 | -- The abstract syntax for expressions in Expresso.
 23 | --
 24 | module Expresso.Syntax where
 25 | 
 26 | import Data.Text (Text)
 27 | import Expresso.Type
 28 | import Expresso.Utils
 29 | 
 30 | -- | Expressions with imports.
 31 | type ExpI  = Fix ((ExpF Name Bind Type :+: K Import) :*: K Pos)
 32 | 
 33 | -- | Expressions with imports resolved.
 34 | type Exp   = Fix (ExpF Name Bind Type :*: K Pos)
 35 | 
 36 | -- | An import file path.
 37 | newtype Import = Import { unImport :: FilePath }
 38 | 
 39 | -- | Pattern functor representing expressions and parameterised with
 40 | -- the type of variable @v@, type of binder @b@ and the type of
 41 | -- type-annotation @t@.
 42 | data ExpF v b t r
 43 |   = EVar  v
 44 |   | EPrim Prim
 45 |   | EApp  r r
 46 |   | ELam  (b v) r
 47 |   | EAnnLam (b v) t r
 48 |   | ELet  (b v) r r
 49 |   | EAnnLet (b v) t r r
 50 |   | EAnn  r t
 51 |   deriving (Show, Functor, Foldable, Traversable)
 52 | 
 53 | -- | Binders
 54 | data Bind v
 55 |   = Arg v
 56 |   | RecArg [(v,v)]
 57 |   | RecWildcard
 58 |   deriving Show
 59 | 
 60 | -- | Language primitives
 61 | data Prim
 62 |   = Int Integer
 63 |   | Dbl Double
 64 |   | Bool Bool
 65 |   | Char Char
 66 |   | Text Text
 67 |   | Show
 68 |   | Trace
 69 |   | ErrorPrim
 70 |   | ArithPrim ArithOp
 71 |   | RelPrim   RelOp
 72 |   | Not
 73 |   | And
 74 |   | Or
 75 |   | Eq
 76 |   | NEq
 77 |   | Double      -- double from int
 78 |   | Floor
 79 |   | Ceiling
 80 |   | Abs
 81 |   | Neg
 82 |   | Mod
 83 |   | Cond
 84 |   | FixPrim
 85 |   | FwdComp
 86 |   | BwdComp
 87 |   | Pack
 88 |   | Unpack
 89 |   | TextAppend
 90 |   | ListEmpty
 91 |   | ListCons
 92 |   | ListUncons
 93 |   | ListAppend
 94 |   | RecordEmpty -- a.k.a. Unit
 95 |   | RecordSelect Label
 96 |   | RecordExtend Label
 97 |   | RecordRestrict Label
 98 |   | Absurd
 99 |   | VariantInject Label
100 |   | VariantEmbed Label
101 |   | VariantElim Label
102 |   deriving (Eq, Ord, Show)
103 | 
104 | data ArithOp = Add | Mul | Sub | Div
105 |   deriving (Eq, Ord, Show)
106 | 
107 | data RelOp   = RGT  | RGTE | RLT  | RLTE
108 |   deriving (Eq, Ord, Show)
109 | 


--------------------------------------------------------------------------------
/lib/Text.x:
--------------------------------------------------------------------------------
  1 | --
  2 | -- Expresso Text Library
  3 | --
  4 | let
  5 |     {..} = import "Prelude.x";
  6 |     list = import "List.x";
  7 | 
  8 |     isEmpty
  9 |         : Text -> Bool
 10 |         = t -> t == "";
 11 | 
 12 |     length
 13 |         : Text -> Int
 14 |         = unpack >> list.length;
 15 | 
 16 |     isSpace
 17 |         : Char -> Bool
 18 |         = c -> c == ' ';
 19 | 
 20 |     isNewLine
 21 |         : Char -> Bool
 22 |         = c -> c == '\n';
 23 | 
 24 |     isUpper
 25 |         : Char -> Bool
 26 |         = c -> c >= 'A' && c <= 'Z';
 27 | 
 28 |     isLower
 29 |         : Char -> Bool
 30 |         = c -> c >= 'a' && c <= 'z';
 31 | 
 32 |     isDigit
 33 |         : Char -> Bool
 34 |         = c -> c >= '0' && c <= '9';
 35 | 
 36 |     isAlpha
 37 |         : Char -> Bool
 38 |         = c -> isUpper c || isLower c;
 39 | 
 40 |     isAlphaNum
 41 |         : Char -> Bool
 42 |         = c -> isAlpha c || isDigit c;
 43 | 
 44 |     concat
 45 |         : [Text] -> Text
 46 |         = list.foldr (t t' -> t <> t') "";
 47 | 
 48 |     intercalate
 49 |         : Text -> [Text] -> Text
 50 |         = s -> map unpack
 51 |             >> list.intersperse (unpack s)
 52 |             >> map pack
 53 |             >> concat;
 54 | 
 55 |     unwords
 56 |         : [Text] -> Text
 57 |         = intercalate " ";
 58 | 
 59 |     isPrefixOf
 60 |         : Text -> Text -> Bool
 61 |         = s s' -> list.isPrefixOf (unpack s) (unpack s');
 62 | 
 63 |     isSuffixOf
 64 |         : Text -> Text -> Bool
 65 |         = s s' -> list.isSuffixOf (unpack s) (unpack s');
 66 | 
 67 |     stripPrefix
 68 |         : Text -> Text -> Maybe Text
 69 |         = s s' -> mapMaybe pack (list.stripPrefix (unpack s) (unpack s'));
 70 | 
 71 |     stripSuffix
 72 |         : Text -> Text -> Maybe Text
 73 |         = s s' -> mapMaybe pack (list.stripSuffix (unpack s) (unpack s'));
 74 | 
 75 |     dropPrefix
 76 |         : Text -> Text -> Text
 77 |         = s s' -> pack (list.dropPrefix (unpack s) (unpack s'));
 78 | 
 79 |     dropSuffix
 80 |         : Text -> Text -> Text
 81 |         = s s' -> pack (list.dropSuffix (unpack s) (unpack s'));
 82 | 
 83 |     replace
 84 |         : Text -> Text -> Text -> Text
 85 |         = from to xs ->
 86 |             if isEmpty from
 87 |             then error "replace: first argument must not be empty"
 88 |             else pack (list.replace (unpack from) (unpack to) (unpack xs));
 89 | 
 90 |     -- Trim spaces from both sides of the given text
 91 |     trim
 92 |         : Text -> Text
 93 |         =  unpack
 94 |         >> list.dropWhile isSpace
 95 |         >> list.dropWhileEnd isSpace
 96 |         >> pack
 97 | 
 98 | -- Exports
 99 | in { isEmpty
100 |    , length
101 |    , isSpace
102 |    , isNewLine
103 |    , isUpper
104 |    , isLower
105 |    , isDigit
106 |    , isAlpha
107 |    , isAlphaNum
108 |    , concat
109 |    , intercalate
110 |    , unwords
111 |    , isPrefixOf
112 |    , isSuffixOf
113 |    , stripPrefix
114 |    , stripSuffix
115 |    , dropPrefix
116 |    , dropSuffix
117 |    , replace
118 |    , trim
119 |    }
120 | 


--------------------------------------------------------------------------------
/lib/Prelude.x:
--------------------------------------------------------------------------------
  1 | --
  2 | -- Expresso Prelude
  3 | --
  4 | 
  5 | type Maybe a = <Just : a, Nothing : {}>;
  6 | type Either a b = <Left : a, Right : b>;
  7 | 
  8 | let
  9 |     id    = x -> x;
 10 |     const = x y -> x;
 11 |     flip  = f x y -> (f y x);
 12 | 
 13 |     ----------------------------------------------------------------
 14 |     -- Basic list operations
 15 | 
 16 |     foldr       = f z -> fix (r xs ->
 17 |                            case uncons xs of
 18 |                              { Nothing{}         -> z
 19 |                              , Just {head, tail} -> f head (r tail)
 20 |                              });
 21 |     null        = xs -> case uncons xs of { Nothing{} -> True, Just{} -> False };
 22 |     map         = f -> foldr (x xs -> f x :: xs) [];
 23 |     filter      = f -> foldr (x xs -> if f x then (x::xs) else xs);
 24 |     length      = foldr (const (n -> 1 + n)) 0;
 25 |     foldl       = f z xs -> foldr (x xsf r -> xsf (f r x)) id xs z;
 26 |     concat      = xss -> foldr (xs ys -> xs ++ ys) [] xss;
 27 | 
 28 |     ----------------------------------------------------------------
 29 |     -- Maybe operations - smart constructors create closed variants
 30 | 
 31 |     just        : forall a. a -> Maybe a
 32 |                 = x -> Just x;
 33 | 
 34 |     nothing     : forall a. Maybe a
 35 |                 = Nothing{};
 36 | 
 37 |     maybe       : forall a b. b -> (a -> b) -> Maybe a -> b
 38 |                 = b f m -> case m of { Just a -> f a, Nothing{} -> b };
 39 | 
 40 |     isJust      = maybe False (const True);
 41 |     isNothing   = maybe True (const False);
 42 |     fromMaybe   = x -> maybe x id;
 43 |     listToMaybe = foldr (x -> const (just x)) nothing;
 44 |     maybeToList = maybe [] (x -> [x]);
 45 |     catMaybes   = xs -> concat (map maybeToList xs);
 46 |     mapMaybe    = f -> maybe nothing (just << f);
 47 | 
 48 |     ----------------------------------------------------------------
 49 |     -- Either operations - smart constructors create closed variants
 50 | 
 51 |     left        : forall a b. a -> Either a b
 52 |                 = x -> Left x;
 53 | 
 54 |     right       : forall a b. b -> Either a b
 55 |                 = x -> Right x;
 56 | 
 57 |     either      : forall a b c. (a -> c) -> (b -> c) -> Either a b -> c
 58 |                 = f g m -> case m of { Left a -> f a, Right b -> g b };
 59 | 
 60 |     ----------------------------------------------------------------
 61 |     -- Logical operations
 62 | 
 63 |     and =  foldr (x y -> x && y) True;
 64 |     or  =  foldr (x y -> x || y) False;
 65 |     any =  p -> or << map p;
 66 |     all =  p -> and << map p;
 67 | 
 68 |     elem    = x -> any (x' -> x' == x);
 69 |     notElem = x -> all (x' -> x' /= x);
 70 | 
 71 |     ----------------------------------------------------------------
 72 |     -- Dynamic binding
 73 | 
 74 |     withOverride  = overrides f self -> overrides (f self);
 75 |     mkOverridable = f -> { override_ = overrides -> (withOverride overrides f) | fix f};
 76 | 
 77 |     override = r overrides -> mkOverridable (r.override_ overrides)
 78 | 
 79 | 
 80 | -- Exports
 81 | in { id
 82 |    , const
 83 |    , foldr
 84 |    , null
 85 |    , map
 86 |    , filter
 87 |    , length
 88 |    , foldl
 89 |    , concat
 90 |    , just
 91 |    , nothing
 92 |    , maybe
 93 |    , isJust
 94 |    , isNothing
 95 |    , fromMaybe
 96 |    , listToMaybe
 97 |    , maybeToList
 98 |    , catMaybes
 99 |    , mapMaybe
100 |    , left
101 |    , right
102 |    , either
103 |    , and
104 |    , or
105 |    , any
106 |    , all
107 |    , elem
108 |    , notElem
109 |    , mkOverridable
110 |    , override
111 |    }
112 | 


--------------------------------------------------------------------------------
/src/Expresso/Utils.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveDataTypeable #-}
  2 | {-# LANGUAGE DeriveFunctor #-}
  3 | {-# LANGUAGE DeriveFoldable #-}
  4 | {-# LANGUAGE DeriveTraversable #-}
  5 | {-# LANGUAGE FlexibleContexts #-}
  6 | {-# LANGUAGE MultiParamTypeClasses #-}
  7 | {-# LANGUAGE ScopedTypeVariables #-}
  8 | {-# LANGUAGE StandaloneDeriving #-}
  9 | {-# LANGUAGE TypeOperators #-}
 10 | {-# LANGUAGE UndecidableInstances #-}
 11 | 
 12 | -- |
 13 | -- Module      : Expresso.Utils
 14 | -- Copyright   : (c) Tim Williams 2017-2019
 15 | -- License     : BSD3
 16 | --
 17 | -- Maintainer  : info@timphilipwilliams.com
 18 | -- Stability   : experimental
 19 | -- Portability : portable
 20 | --
 21 | -- Recursion scheme utilities.
 22 | --
 23 | module Expresso.Utils(
 24 |   Fix(..),
 25 |   K(..),
 26 |   (:*:)(..),
 27 |   (:+:)(..),
 28 |   cata,
 29 |   cataM,
 30 |   para,
 31 |   ana,
 32 |   (&&&),
 33 |   (***),
 34 |   first,
 35 |   second,
 36 |   showError,
 37 |   View(..),
 38 |   annotate,
 39 |   stripAnn,
 40 |   getAnn,
 41 |   withAnn
 42 | )
 43 | where
 44 | 
 45 | import Control.Monad
 46 | import Data.Data
 47 | 
 48 | newtype Fix f = Fix { unFix :: f (Fix f) }
 49 | 
 50 | deriving instance (Typeable f, Data (f (Fix f))) => Data (Fix f)
 51 | 
 52 | data K a b = K { unK :: a }
 53 |   deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
 54 | 
 55 | data (f :*: g) a = (:*:) { left :: f a, right :: g a }
 56 |   deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
 57 | 
 58 | data (f :+: g) a = InL (f a) | InR (g a)
 59 |   deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
 60 | 
 61 | cata :: Functor f => (f a -> a) -> Fix f -> a
 62 | cata phi = phi . fmap (cata phi) . unFix
 63 | 
 64 | cataM :: (Monad m, Traversable f) =>
 65 |          (f a -> m a) -> Fix f -> m a
 66 | cataM algM = algM <=< (mapM (cataM algM) . unFix)
 67 | 
 68 | para :: Functor f => (f (b, Fix f) -> b) -> Fix f -> b
 69 | para phi = phi . fmap (para phi &&& id) . unFix
 70 | 
 71 | ana :: Functor f => (a -> f a) -> a -> Fix f
 72 | ana coalg = Fix . fmap (ana coalg) . coalg
 73 | 
 74 | -- Equivalent to specialized version from Arrow
 75 | (&&&) :: (a -> b) -> (a -> c) -> (a -> (b,c))
 76 | f &&& g = \a -> (f a, g a)
 77 | 
 78 | -- Equivalent to specialized version from Arrow
 79 | (***) :: (a -> b) -> (c -> d) -> ((a, c) -> (b, d))
 80 | f *** g = \(a, b) -> (f a, g b)
 81 | 
 82 | -- Equivalent to specialized version from Arrow
 83 | first :: (a -> b) -> (a,c) -> (b,c)
 84 | first f (a,c) = (f a, c)
 85 | 
 86 | -- Equivalent to specialized version from Arrow
 87 | second :: (b -> c) -> (a,b) -> (a,c)
 88 | second f (a,b) = (a, f b)
 89 | 
 90 | instance (Functor f, Show (f (Fix f))) => Show (Fix f) where
 91 |     showsPrec d (Fix f) = showsPrec d f
 92 | 
 93 | instance (Functor f, Eq (f (Fix f))) => Eq (Fix f) where
 94 |     fa == fb = unFix fa == unFix fb
 95 | 
 96 | instance (Functor f, Ord (f (Fix f))) => Ord (Fix f) where
 97 |     compare fa fb = compare (unFix fa) (unFix fb)
 98 | 
 99 | class View f a where
100 |   proj :: a -> f a
101 |   inj  :: f a -> a
102 | 
103 | showError :: Show a => Either a b -> Either String b
104 | showError = either (Left . show) Right
105 | 
106 | -- | add annotation
107 | annotate :: forall f a. Functor f => a -> Fix f -> Fix (f :*: K a)
108 | annotate ann = cata alg where
109 |   alg :: f (Fix (f :*: K a)) -> Fix (f :*: K a)
110 |   alg e = Fix (e :*: K ann)
111 | 
112 | -- | strip annotations
113 | stripAnn :: forall f a. Functor f => Fix (f :*: K a) -> Fix f
114 | stripAnn = cata alg where
115 |   alg :: (f :*: K a) (Fix f) -> Fix f
116 |   alg (e :*: _) = Fix e
117 | 
118 | -- | retrieve annotation
119 | getAnn :: Fix (f :*: K a) -> a
120 | getAnn = unK . right . unFix
121 | 
122 | -- | fix with annotation
123 | withAnn :: a -> f (Fix (f :*: K a) )-> Fix (f :*: K a)
124 | withAnn ann e = Fix (e :*: K ann)
125 | 


--------------------------------------------------------------------------------
/expresso.cabal:
--------------------------------------------------------------------------------
  1 | Name:            expresso
  2 | Version:         0.1.3.0
  3 | Cabal-Version:   >= 1.10
  4 | License:         BSD3
  5 | License-File:    LICENSE
  6 | Author:          Tim Williams
  7 | Maintainer:      info@timphilipwilliams.com
  8 | Stability:       Experimental
  9 | Synopsis:        A simple expressions language based on row types
 10 | Category:        Configuration
 11 | Description:
 12 |     Expresso is a minimal statically-typed functional programming language, designed with embedding and/or extensibility in mind.
 13 |     .
 14 |     Possible use cases for such a minimal language include configuration (à la Nix), data exchange (à la JSON) or even a starting point for a custom external DSL.
 15 |     .
 16 |     Please refer to README.md for more information.
 17 | Build-Type:      Simple
 18 | Bug-Reports:     https://github.com/willtim/Expresso/issues
 19 | Data-Files:
 20 |     Prelude.x
 21 |     List.x
 22 |     Text.x
 23 | Data-Dir:
 24 |     lib
 25 | Extra-Source-Files:
 26 |     CHANGELOG.md
 27 |     README.md
 28 | 
 29 | Source-Repository head
 30 |   Type: git
 31 |   Location: https://github.com/willtim/Expresso
 32 | 
 33 | Library
 34 |   Hs-Source-Dirs:   src
 35 |   Default-Language: Haskell2010
 36 |   Build-Depends:    base                 >= 4.11.1 && < 5,
 37 |                     containers           >= 0.5.11 && < 0.7,
 38 |                     directory            >= 1.3.1 && < 1.4,
 39 |                     filepath             >= 1.4.2 && < 1.5,
 40 |                     hashable             >= 1.2.7 && < 1.4,
 41 |                     text                 >= 1.2.3 && < 1.3,
 42 |                     haskeline            >= 0.7.4 && < 0.8,
 43 |                     mtl                  >= 2.2.2 && < 2.3,
 44 |                     parsec               >= 3.1.13 && < 3.2,
 45 |                     template-haskell     >= 2.13.0 && < 2.16,
 46 |                     unordered-containers >= 0.2.9 && < 0.3,
 47 |                     wl-pprint            >= 1.2.1 && < 1.3
 48 | 
 49 |   Exposed-Modules:  Expresso
 50 |                     Expresso.TH.QQ
 51 |   Other-Modules:    Expresso.Parser
 52 |                     Expresso.Eval
 53 |                     Expresso.Type
 54 |                     Expresso.TypeCheck
 55 |                     Expresso.Syntax
 56 |                     Expresso.Pretty
 57 |                     Expresso.Utils
 58 | 
 59 |   ghc-options:      -Wall -fwarn-tabs -funbox-strict-fields
 60 |                     -fno-warn-orphans
 61 |                     -fno-warn-unused-do-bind
 62 |                     -fno-warn-name-shadowing
 63 |                     -fno-warn-missing-pattern-synonym-signatures
 64 | 
 65 | Executable expresso
 66 |   Main-Is:          Repl.hs
 67 |   Hs-Source-Dirs:   src
 68 |   Default-Language: Haskell2010
 69 |   Build-Depends:    base, containers, hashable, mtl, parsec, wl-pprint, text,
 70 |                     unordered-containers, haskeline, directory, filepath
 71 | 
 72 |   Other-Modules:    Expresso.Parser
 73 |                     Expresso.Eval
 74 |                     Expresso.Type
 75 |                     Expresso.TypeCheck
 76 |                     Expresso.Syntax
 77 |                     Expresso.Pretty
 78 |                     Expresso.Utils
 79 |                     Expresso
 80 |                     Paths_expresso
 81 | 
 82 |   ghc-options: -threaded -rtsopts -Wall -fwarn-tabs -funbox-strict-fields
 83 |                -fno-warn-orphans
 84 |                -fno-warn-unused-do-bind
 85 |                -fno-warn-name-shadowing
 86 |                -fno-warn-missing-pattern-synonym-signatures
 87 | 
 88 | Test-Suite test-expresso
 89 |   Type:             exitcode-stdio-1.0
 90 |   Main-Is:          Tests.hs
 91 |   Hs-Source-Dirs:   src
 92 |   Default-Language: Haskell2010
 93 | 
 94 |   Build-Depends:    base, containers, hashable, mtl, parsec, wl-pprint, text,
 95 |                     unordered-containers, haskeline, directory, filepath,
 96 |                     expresso, tasty, tasty-hunit
 97 | 
 98 |   Other-Modules:    Expresso
 99 |                     Expresso.Eval
100 |                     Expresso.Parser
101 |                     Expresso.Pretty
102 |                     Expresso.Syntax
103 |                     Expresso.Type
104 |                     Expresso.TypeCheck
105 |                     Expresso.Utils
106 |                     Paths_expresso
107 | 


--------------------------------------------------------------------------------
/lib/List.x:
--------------------------------------------------------------------------------
  1 | --
  2 | -- Expresso additional List operations
  3 | --
  4 | let
  5 | 
  6 |     {..} = import "Prelude.x";
  7 | 
  8 |     reverse
  9 |         : forall a. [a] -> [a]
 10 |         = foldl (xs x -> x :: xs) [];
 11 | 
 12 |     tails
 13 |         : forall a. [a] -> [[a]]
 14 |         = fix (r xs ->
 15 |                   case uncons xs of
 16 |                     { Nothing{} -> [[]]
 17 |                     , Just{tail=xs'} -> xs :: r xs'
 18 |                     });
 19 | 
 20 |     intersperse
 21 |         : forall a. a -> [a] -> [a]
 22 |         = sep xs ->
 23 |         let f   = x xs -> (if null xs then [x] else x :: sep :: xs)
 24 |         in foldr f [] xs;
 25 | 
 26 |     intercalate
 27 |         : forall a. [a] -> [[a]] -> [a]
 28 |         = xs xss -> concat (intersperse xs xss);
 29 | 
 30 |     dropWhile
 31 |         : forall a. (a -> Bool) -> [a] -> [a]
 32 |         = p -> xs -> foldr (x r b ->
 33 |         if b && p x then r True else x::r False) (const []) xs True;
 34 | 
 35 |     dropWhileEnd
 36 |         : forall a. (a -> Bool) -> [a] -> [a]
 37 |         = p -> foldr (x xs -> if null xs && p x then [] else x :: xs) [];
 38 | 
 39 |     takeWhile
 40 |         : forall a. (a -> Bool) -> [a] -> [a]
 41 |         = p -> foldr (x xs -> if p x then x :: xs else []) [];
 42 | 
 43 |     takeWhileEnd
 44 |         : forall a. (a -> Bool) -> [a] -> [a]
 45 |         = p -> reverse << takeWhile p << reverse;
 46 | 
 47 |     isPrefixOf
 48 |         : forall a. Eq a => [a] -> [a] -> Bool
 49 |         = fix (r xs ys ->
 50 |                   case uncons xs of
 51 |                     { Nothing{} -> True
 52 |                     , Just {head=x, tail=xs'} ->
 53 |                         case uncons ys of
 54 |                           { Nothing{} -> False
 55 |                           , Just {head=y, tail=ys'} ->
 56 |                               x==y && r xs' ys'
 57 |                           }
 58 |                     });
 59 | 
 60 |     isSuffixOf
 61 |         : forall a. Eq a => [a] -> [a] -> Bool
 62 |         = xs ys -> isPrefixOf (reverse xs) (reverse ys);
 63 | 
 64 |     stripPrefix
 65 |         : forall a. Eq a => [a] -> [a] -> Maybe [a]
 66 |         = fix (r xs ys ->
 67 |                   case uncons xs of
 68 |                      { Nothing{} -> Just ys
 69 |                      , Just{head=x,tail=xs'} ->
 70 |                        case uncons ys of
 71 |                          { Nothing{} -> Nothing{}
 72 |                          , Just {head=y, tail=ys'} ->
 73 |                              if x==y then r xs' ys' else Nothing{}
 74 |                          }
 75 |                    });
 76 | 
 77 |     stripSuffix
 78 |         : forall a. Eq a => [a] -> [a] -> Maybe [a]
 79 |         = xs ys -> stripPrefix (reverse xs) (reverse ys);
 80 | 
 81 |     dropPrefix
 82 |         : forall a. Eq a => [a] -> [a] -> [a]
 83 |         = xs ys -> fromMaybe ys (stripPrefix xs ys);
 84 | 
 85 |     dropSuffix
 86 |         : forall a. Eq a => [a] -> [a] -> [a]
 87 |         = xs ys -> fromMaybe ys (stripSuffix xs ys);
 88 | 
 89 |     zipWith
 90 |         : forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
 91 |         = f -> fix (r xs ys ->
 92 |                       case uncons xs of
 93 |                          { Nothing{} -> []
 94 |                          , Just{head=x,tail=xs'} ->
 95 |                            case uncons ys of
 96 |                              { Nothing{} -> []
 97 |                              , Just {head=y, tail=ys'} ->
 98 |                                  f x y :: r xs' ys'
 99 |                              }
100 |                        });
101 | 
102 |     zip : forall a b. [a] -> [b] -> [{l:a, r:b}]
103 |         = zipWith (a b -> { l = a, r = b });
104 | 
105 | 
106 |     replace
107 |         : forall a. Eq a => [a] -> [a] -> [a] -> [a]
108 |         = fix (r from to xs ->
109 |             if null from then xs
110 |             else case stripPrefix from xs of
111 |               { Just xs'  -> to ++ r from to xs'
112 |               , Nothing{} -> case uncons xs of
113 |                                { Nothing{} -> []
114 |                                , Just{head=x, tail=xs'} ->
115 |                                    x :: r from to xs'
116 |                                }})
117 | 
118 |    -- Prelude re-exports
119 | in { foldr
120 |    , null
121 |    , map
122 |    , filter
123 |    , length
124 |    , foldl
125 |    , concat
126 | 
127 |    -- Exports
128 |    , reverse
129 |    , tails
130 |    , intersperse
131 |    , intercalate
132 |    , dropWhile
133 |    , dropWhileEnd
134 |    , takeWhile
135 |    , takeWhileEnd
136 |    , isPrefixOf
137 |    , isSuffixOf
138 |    , stripPrefix
139 |    , stripSuffix
140 |    , dropPrefix
141 |    , dropSuffix
142 |    , zipWith
143 |    , zip
144 |    , replace
145 |    }
146 | 


--------------------------------------------------------------------------------
/src/Tests.hs:
--------------------------------------------------------------------------------
  1 | module Main where
  2 | 
  3 | import Test.Tasty (TestTree, defaultMain, testGroup)
  4 | import Test.Tasty.HUnit (assertEqual, assertFailure, testCase)
  5 | import Data.HashMap.Strict (HashMap)
  6 | import qualified Data.HashMap.Strict as HashMap
  7 | 
  8 | import Expresso
  9 | 
 10 | import Paths_expresso
 11 | 
 12 | main = defaultMain unitTests
 13 | 
 14 | unitTests = testGroup
 15 |   "End-to-end functional tests"
 16 |   [ letTests
 17 |   , lambdaTests
 18 |   , recordTests
 19 |   , variantTests
 20 |   , listTests
 21 |   , relationalTests
 22 |   , inferenceTests
 23 |   , constraintTests
 24 |   , rankNTests
 25 |   , lazyTests
 26 |   ]
 27 | 
 28 | letTests = testGroup
 29 |   "Let expressions"
 30 |   [ hasValue "let x = 1 in x" (1::Integer)
 31 |   , hasValue "let x = 1 in let y = 2 in x + y" (3::Integer)
 32 |   , hasValue "let x = 1; y = 2 in x + y" (3::Integer)
 33 |   , hasValue "let {..} = {inc = x -> x + 1} in inc 1" (2::Integer)
 34 |   , hasValue "let m = {inc = x -> x + 1} in m.inc 1" (2::Integer)
 35 | 
 36 |   , hasValue "let m = {id = x -> x} in {foo = [m.id 1], bar = m.id [1]}"
 37 |         ["foo" --> ([1]::[Integer]), "bar" --> ([1]::[Integer])]
 38 | 
 39 |   -- Record argument field-pun generalisation
 40 |   , hasValue "let {id} = {id = x -> x} in {foo = [id 1], bar = id [1]}"
 41 |         ["foo" --> ([1]::[Integer]), "bar" --> ([1]::[Integer])]
 42 |   , hasValue "let {..} = {id = x -> x} in {foo = [id 1], bar = id [1]}"
 43 |         ["foo" --> ([1]::[Integer]), "bar" --> ([1]::[Integer])]
 44 | 
 45 |     -- Num constraint violation
 46 |   , illTyped "let square = x -> x * x in {foo = square 1, bar = square [1]}"
 47 |   ]
 48 | 
 49 | lambdaTests = testGroup
 50 |   "Lambda expressions"
 51 |   [ hasValue "(x -> y -> x + y) 1 2" (3::Integer)
 52 |   , hasValue "(x y -> x + y) 1 2" (3::Integer)
 53 |   , illTyped "x -> x x"
 54 |   , illTyped "let absorb = fix (r x -> r) in absorb"
 55 |   , illTyped "let create = fix (r x -> r x x) in create"
 56 |   ]
 57 | 
 58 | recordTests = testGroup
 59 |   "Record expressions"
 60 |   [ hasValue "({x, y} -> {x, y}) {x=1, y=2}" $ toMap ["x"-->(1::Integer), "y"-->2]
 61 |   , hasValue "{x = 1, y = 2}" $ toMap ["x"-->(1::Integer), "y"-->2]
 62 |   , hasValue "(r -> { x = 1, y = 2 | r}) { z = 3 }" $ toMap ["x"-->(1::Integer), "y"-->2, "z"-->3]
 63 |   , hasValue "{ x = { y = { z = 42 }}}.x.y.z" (42::Integer)
 64 | 
 65 |   -- Row tail unification soundness
 66 |   , illTyped "r -> if True then { x = 1 | r } else { y = 2 | r }"
 67 | 
 68 |   , illTyped "{ x = 2, x = 1 }.x" -- fails to typecheck
 69 |   , illTyped "{ x = 2 | { x = 1 }}.x" -- fails to typecheck
 70 |   , hasValue "{ x := 2, x = 1 }.x" (2::Integer)
 71 |   , hasValue "{ x := 2 | { x = 1 }}.x" (2::Integer)
 72 |   , hasValue "{| x = 1 |} {}" $ toMap ["x"-->(1::Integer)]
 73 |   , hasValue "({| x = 1, y = 2 |} >> {| z = 3 |}) {}" $ toMap ["x"-->(1::Integer), "y"-->2, "z"-->3]
 74 |   , hasValue "({| x = 1, y = 2 |} >> {| x := 42 |}) {}" $ toMap ["x"-->(42::Integer), "y"-->2]
 75 |   , illTyped "({| x = 1, y = 2 |} << {| x := 42 |}) {}" -- fails to typecheck
 76 |   , hasValue "({| x := 42, y = 2 |} << {| x = 1 |}) {}" ["x"-->(42::Integer), "y"-->2]
 77 |   ]
 78 | 
 79 | variantTests = testGroup
 80 |   "Variant expressions"
 81 |   [ hasValue "case Foo 1 of { Foo x -> x + 1, Bar {x, y} -> x + y }"   (2::Integer)
 82 |   , hasValue "case Bar {x=1, y=2} of { Foo x -> x + 1, Bar {x, y} -> x + y }"   (3::Integer)
 83 |   , illTyped "case Baz{} of { Foo x -> x + 1, Bar {x, y} -> x + y }" -- fails to typecheck
 84 |   , hasValue "case Baz{} of { Foo x -> x + 1, Bar {x, y} -> x + y | otherwise -> 42 }"  (42::Integer)
 85 |   , illTyped "let f = s -> case s of { Foo x -> x + 1, Bar {x, y} -> x + y }; g = s -> f (<|Foo|> s) in g (Foo 1)" -- fails to typecheck
 86 |   , hasValue "let f = s -> case s of { Foo x -> x + 1, Bar {x, y} -> x + y }; g = s -> f (<|Foo|> s) in g (Bar{x=1, y=2})" (3::Integer)
 87 |   , hasValue "let f = s -> case s of { Foo x -> x + 1, Bar {x, y} -> x + y | otherwise -> 42 }; g = s -> f (<|Foo,Bar|> s) in g (Baz{})"  (42::Integer)
 88 |   , hasValue "case Foo 1 of { override Foo x -> x + 2 | s -> case s of { Foo x -> x + 1 }}" (3::Integer)
 89 |   , hasValue "case Foo 1 of { override Foo x -> x + 2, Foo x -> x + 1 }" (3::Integer)
 90 | 
 91 |   -- Fail in empty row case
 92 |   , illTyped "x -> case x of { A{} -> 1, B{} -> 2, A{} -> 3 }"
 93 |   -- Fail in row var case
 94 |   , illTyped "x -> <|A, B, A|> x"
 95 |   -- Failed row rewrite due to row constraints
 96 |   , illTyped ("let f = x -> case (<|A|> x) of { B{} -> 1, otherwise -> 2 }; " ++
 97 |               "let g = x -> case (<|B|> x) of { A{} -> 1, otherwise -> 2 } in " ++
 98 |               "x -> f x + f x")
 99 |   ]
100 | 
101 | listTests = testGroup
102 |   "List expressions"
103 |   [ hasValue "[1,2,3]" [1::Integer,2,3]
104 |   , illTyped "[1,True]"
105 |   ]
106 | 
107 | relationalTests = testGroup
108 |   "Relational expressions"
109 |   [ hasValue "(1 == 2)" False
110 |   , hasValue "1/=2" True
111 |   , illTyped "1 == 2 == 3"
112 |   , hasValue "{x = 1, y = True} == {y = True, x = 1}" True -- field order should not matter
113 |   , illTyped "{x = 1, y = True} > {y = True, x = 1}" -- cannot compare records for ordering
114 |   , hasValue "Just 1 == Just 1" True -- variants can be compared for equality
115 |   , illTyped "Foo 1 > Bar{}" -- cannot compare variants for ordering
116 |   , hasValue "[1,2,3] == [1,2,3]" True -- lists can be compared for equality
117 |   , hasValue "[1,2,3] >= [1,2,2]" True -- lists can be compared for ordering
118 |   , hasValue "True&&True"   True
119 |   , hasValue "True||False"  True
120 |   ]
121 | 
122 | inferenceTests = testGroup
123 |   "Type inference tests"
124 |   [ hasType "n d -> if d == 0 then DivBy0 {} else Ok (n / d)"
125 |             "forall r. (r\\DivBy0\\Ok) => Int -> Int -> <DivBy0 : {}, Ok : Int | r>"
126 |   ]
127 | 
128 | constraintTests = testGroup
129 |   "Constraint violations"
130 |   [ illTyped "show { x = \"test\", y = Just (x -> x) }"
131 |   , illTyped "{ x = 2 } > { x = 1}"
132 |   , illTyped "let f = x y -> x + y in f True False"
133 |   ]
134 | 
135 | rankNTests = testGroup
136 |   "Rank-N polymorphism"
137 |   [ hasValue "let f = (g : forall a. a -> a) -> {l = g True, r = g 1} in f (x -> x) == {l = True, r = 1}" True
138 |   , hasValue "let f = g -> {l = g True, r = g 1} : (forall a. a -> a) -> {l : Bool, r : Int } in f (x -> x) == {l = True, r = 1}" True , hasValue "let f = (m : forall a. { reverse : [a] -> [a] |_}) -> {l = m.reverse [True, False], r = pack (m.reverse (unpack \"abc\")) } in f (import \"List.x\") == {l = [False, True], r = \"cba\"}" True
139 |   ]
140 | 
141 | lazyTests = testGroup
142 |   "Lazy evaluation tests using error primitive"
143 |   [ -- hasValue "maybe (error \"bang!\") (x -> x == 42) (Just 42)" True
144 |     hasValue "{ x = error \"boom!\", y = 42 }.y" (42::Integer)
145 |   , hasValue "case Bar (error \"fizzle!\") of { Foo{} -> 0 | otherwise -> 42 }" (42::Integer)
146 |   ]
147 | 
148 | hasValue :: (Eq a, Show a, HasValue a) => String -> a -> TestTree
149 | hasValue str expected = testCase str $ do
150 |     libDir <- getDataDir
151 |     let envs = setLibDirs [libDir] initEnvironments
152 |     result <- evalString' envs Nothing str
153 |     case result of
154 |         Left err     -> assertFailure err
155 |         Right actual -> assertEqual "" expected actual
156 | 
157 | hasType :: String -> String -> TestTree
158 | hasType str expected = testCase str $ do
159 |     result <- typeOfString str
160 |     case result of
161 |         Left err     -> assertFailure err
162 |         Right actual -> assertEqual "" expected (showType actual)
163 | 
164 | illTyped :: String -> TestTree
165 | illTyped str = testCase str $ do
166 |     sch'e <- typeOfString str
167 |     case sch'e of
168 |         Left _    -> assertTrue
169 |         Right sch -> assertFailure $ "Should not type-check, but got: " ++ showType sch
170 | 
171 | assertTrue = return ()
172 | 
173 | (-->) :: HasValue a => Name -> a -> (Name, a)
174 | (-->) l v = (l, v)
175 | 
176 | toMap :: (Eq a, Show a, HasValue a) => [(Name, a)] -> HashMap Name a
177 | toMap = HashMap.fromList
178 | 


--------------------------------------------------------------------------------
/src/Expresso.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts #-}
  2 | {-# LANGUAGE TupleSections #-}
  3 | {-# LANGUAGE PatternSynonyms #-}
  4 | {-# OPTIONS_GHC -Wno-unused-top-binds #-}
  5 | 
  6 | -- |
  7 | -- Module      : Expresso
  8 | -- Copyright   : (c) Tim Williams 2017-2019
  9 | -- License     : BSD3
 10 | --
 11 | -- Maintainer  : info@timphilipwilliams.com
 12 | -- Stability   : experimental
 13 | -- Portability : portable
 14 | --
 15 | -- A simple expressions language with polymorphic extensible row types.
 16 | --
 17 | -- This module is the public API for Expresso.
 18 | --
 19 | module Expresso
 20 |   ( Bind(..)
 21 |   , Env
 22 |   , Environments
 23 |   , Exp
 24 |   , ExpF(..)
 25 |   , ExpI
 26 |   , HasValue(..)
 27 |   , Import(..)
 28 |   , Name
 29 |   , SynonymDecl(..)
 30 |   , Thunk(..)
 31 |   , TIState
 32 |   , Type
 33 |   , pattern TForAll
 34 |   , pattern TVar
 35 |   , pattern TMetaVar
 36 |   , pattern TInt
 37 |   , pattern TDbl
 38 |   , pattern TBool
 39 |   , pattern TChar
 40 |   , pattern TText
 41 |   , pattern TFun
 42 |   , pattern TList
 43 |   , pattern TRecord
 44 |   , pattern TVariant
 45 |   , pattern TRowEmpty
 46 |   , pattern TRowExtend
 47 |   , TypeF(..)
 48 |   , TypeEnv
 49 |   , Value(..)
 50 |   , bind
 51 |   , dummyPos
 52 |   , evalFile
 53 |   , evalFile'
 54 |   , evalString
 55 |   , evalString'
 56 |   , evalWithEnv
 57 |   , initEnvironments
 58 |   , installBinding
 59 |   , installSynonyms
 60 |   , uninstallSynonym
 61 |   , runEvalM
 62 |   , setLibDirs
 63 |   , showType
 64 |   , showValue
 65 |   , showValue'
 66 |   , dumpTypeEnv
 67 |   , typeOf
 68 |   , typeOfString
 69 |   , typeOfWithEnv
 70 |   , validate
 71 |   , Eval.choice
 72 |   , Eval.mkRecord
 73 |   , Eval.mkStrictLam
 74 |   , Eval.mkStrictLam2
 75 |   , Eval.mkStrictLam3
 76 |   , Eval.mkVariant
 77 |   , Eval.typeMismatch
 78 |   , Eval.unit
 79 |   , (Eval..:)
 80 |   , (Eval..=)
 81 |   ) where
 82 | 
 83 | import Control.Monad ((>=>))
 84 | import Control.Monad.Except ( MonadError, ExceptT(..), runExceptT
 85 |                             , throwError)
 86 | 
 87 | import Expresso.Eval ( Env, EvalM, HasValue(..), Thunk(..), Value(..)
 88 |                      , insertEnv, runEvalM)
 89 | import Expresso.TypeCheck (TIState, initTIState)
 90 | import Expresso.Pretty (render)
 91 | import Expresso.Syntax
 92 | import Expresso.Type
 93 | import Expresso.Utils
 94 | import qualified Expresso.Eval as Eval
 95 | import qualified Expresso.TypeCheck as TypeCheck
 96 | import qualified Expresso.Parser as Parser
 97 | 
 98 | -- | Type and term environments.
 99 | data Environments = Environments
100 |     { envsLibDirs  :: ![FilePath]
101 |     , envsTypeEnv  :: !TypeEnv
102 |     , envsSynonyms :: !Synonyms
103 |     , envsTIState  :: !TIState
104 |     , envsTermEnv  :: !Env
105 |     }
106 | 
107 | -- | Empty initial environments.
108 | initEnvironments :: Environments
109 | initEnvironments = Environments [] mempty mempty initTIState mempty
110 | 
111 | -- | Install a binding using the supplied name, type and term.
112 | -- Useful for extending the set of built-in functions.
113 | installBinding :: Name -> Type -> Value -> Environments -> Environments
114 | installBinding name ty val envs =
115 |     envs { envsTypeEnv = insertTypeEnv name ty (envsTypeEnv envs)
116 |          , envsTermEnv = insertEnv name (Thunk . return $ val) (envsTermEnv envs)
117 |          }
118 | 
119 | -- | Query the type of an expression using the supplied type environment.
120 | typeOfWithEnv :: Environments -> ExpI -> IO (Either String Type)
121 | typeOfWithEnv (Environments libDirs tEnv syns tState _) ei = runExceptT $ do
122 |     (e, ss) <- Parser.resolveImports libDirs ei
123 |     syns'   <- insertSynonyms ss syns
124 |     ExceptT $ return $ inferTypes tEnv syns' tState e
125 | 
126 | -- | Query the type of an expression.
127 | typeOf :: ExpI -> IO (Either String Type)
128 | typeOf = typeOfWithEnv initEnvironments
129 | 
130 | -- | Parse an expression and query its type.
131 | typeOfString :: String -> IO (Either String Type)
132 | typeOfString str = runExceptT $ do
133 |     (_, top) <- ExceptT $ return $ Parser.parse "<unknown>" str
134 |     ExceptT $ typeOf top
135 | 
136 | -- | Evaluate an expression using the supplied type and term environments.
137 | evalWithEnv
138 |     :: HasValue a
139 |     => Environments
140 |     -> ExpI
141 |     -> IO (Either String a)
142 | evalWithEnv (Environments libDirs tEnv syns tState env) ei = runExceptT $ do
143 |     (e, ss) <- Parser.resolveImports libDirs ei
144 |     syns'   <- insertSynonyms ss syns
145 |     _sigma  <- ExceptT . return $ inferTypes tEnv syns' tState e
146 |     ExceptT $ runEvalM . (Eval.eval env >=> Eval.proj) $ e
147 | 
148 | -- | Evaluate the contents of the supplied file path; and optionally
149 | -- validate using a supplied type (schema).
150 | evalFile :: HasValue a => Maybe Type -> FilePath -> IO (Either String a)
151 | evalFile = evalFile' initEnvironments
152 | 
153 | -- | Evaluate the contents of the supplied file path; and optionally
154 | -- validate using a supplied type (schema).
155 | -- NOTE: This version also takes a term environment and a type environment
156 | -- so that foreign functions and their types can be installed respectively.
157 | evalFile' :: HasValue a => Environments -> Maybe Type -> FilePath -> IO (Either String a)
158 | evalFile' envs mty path = runExceptT $ do
159 |     (ss, top) <- ExceptT $ Parser.parse path <$> readFile path
160 |     envs' <- installSynonyms ss envs
161 |     ExceptT $ evalWithEnv envs' (maybe id validate mty $ top)
162 | 
163 | -- | Parse an expression and evaluate it; optionally
164 | -- validate using a supplied type (schema).
165 | evalString :: HasValue a => Maybe Type -> String -> IO (Either String a)
166 | evalString = evalString' initEnvironments
167 | 
168 | -- | Parse an expression and evaluate it; optionally
169 | -- validate using a supplied type (schema).
170 | -- NOTE: This version also takes a term environment and a type environment
171 | -- so that foreign functions and their types can be installed respectively.
172 | evalString' :: HasValue a => Environments -> Maybe Type -> String -> IO (Either String a)
173 | evalString' envs mty str = runExceptT $ do
174 |     (ss, top) <- ExceptT $ return $ Parser.parse "<unknown>" str
175 |     envs' <- installSynonyms ss envs
176 |     ExceptT $ evalWithEnv envs' (maybe id validate mty $ top)
177 | 
178 | -- | Add a validating type signature section to the supplied expression.
179 | validate :: Type -> ExpI -> ExpI
180 | validate ty e = Parser.mkApp pos (Parser.mkSigSection pos ty) [e]
181 |   where
182 |     pos = dummyPos
183 | 
184 | -- | Used by the REPL to bind variables.
185 | bind
186 |     :: Environments
187 |     -> Bind Name
188 |     -> Maybe Type
189 |     -> ExpI
190 |     -> EvalM Environments
191 | bind (Environments libDirs tEnv syns tState env) b mty ei = do
192 |     (e, ss) <- Parser.resolveImports libDirs ei
193 |     syns'   <- insertSynonyms ss syns
194 |     let (res'e, tState') =
195 |             TypeCheck.runTI (TypeCheck.tcDecl (getAnn ei) b mty e) tEnv syns' tState
196 |     case res'e of
197 |         Left err    -> throwError err
198 |         Right tEnv' -> do
199 |             thunk <- Eval.mkThunk $ Eval.eval env e
200 |             env'  <- Eval.bind env b thunk
201 |             return $ Environments libDirs tEnv' syns' tState' env'
202 | 
203 | -- | Pretty print the supplied type.
204 | showType :: Type -> String
205 | showType = render . ppType
206 | 
207 | -- | Pretty print the supplied value. This does *not* evaluate deeply.
208 | showValue :: Value -> String
209 | showValue = render . Eval.ppValue
210 | 
211 | -- | Pretty print the supplied value. This evaluates deeply.
212 | showValue' :: Value -> IO String
213 | showValue' v = either id render <$> (runEvalM $ Eval.ppValue' v)
214 | 
215 | -- | Extract type environment bindings.
216 | dumpTypeEnv :: Environments -> [(Name, Sigma)]
217 | dumpTypeEnv = typeEnvToList . envsTypeEnv
218 | 
219 | inferTypes
220 |     :: TypeEnv
221 |     -> Synonyms
222 |     -> TIState
223 |     -> Exp
224 |     -> Either String Type
225 | inferTypes tEnv syns tState e =
226 |     fst $ TypeCheck.runTI (TypeCheck.typeCheck e) tEnv syns tState
227 | 
228 | -- | Set the library paths used when resolving relative imports.
229 | setLibDirs :: [FilePath] -> Environments -> Environments
230 | setLibDirs libDirs envs =
231 |     envs { envsLibDirs = libDirs }
232 | 
233 | -- | Install the supplied type synonym declarations.
234 | installSynonyms
235 |     :: MonadError String m
236 |     => [SynonymDecl]
237 |     -> Environments
238 |     -> m Environments
239 | installSynonyms ss envs = do
240 |     syns' <- insertSynonyms ss (envsSynonyms envs)
241 |     return $ envs { envsSynonyms = syns' }
242 | 
243 | -- | Used by the REPL, deletes any previous definition.
244 | uninstallSynonym
245 |     :: SynonymDecl
246 |     -> Environments
247 |     -> Environments
248 | uninstallSynonym s envs =
249 |     let syns' = deleteSynonym (synonymName s)
250 |               $ envsSynonyms envs
251 |     in envs { envsSynonyms = syns' }
252 | 


--------------------------------------------------------------------------------
/src/Repl.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE ScopedTypeVariables #-}
  2 | {-# LANGUAGE TupleSections #-}
  3 | 
  4 | -- |
  5 | -- Module      : Main
  6 | -- Copyright   : (c) Tim Williams 2017-2019
  7 | -- License     : BSD3
  8 | --
  9 | -- Maintainer  : info@timphilipwilliams.com
 10 | -- Stability   : experimental
 11 | -- Portability : portable
 12 | --
 13 | -- Expresso Read-Eval-Print-Loop.
 14 | --
 15 | module Main where
 16 | 
 17 | import Control.Applicative
 18 | import Control.Monad (forM_)
 19 | import Control.Monad.Except
 20 | import Control.Monad.State.Strict
 21 | import Data.Char
 22 | import Data.Version
 23 | import System.Console.Haskeline (InputT)
 24 | import System.Console.Haskeline.MonadException ()
 25 | import System.Directory
 26 | import System.FilePath
 27 | import Text.Parsec.String (Parser)
 28 | import qualified System.Console.Haskeline as HL
 29 | import qualified Text.Parsec as P
 30 | 
 31 | import Expresso
 32 | import Expresso.Parser ( pExp, pLetDecl, pSynonymDecl, topLevel
 33 |                        , reserved, reservedOp, stringLiteral
 34 |                        )
 35 | import Expresso.Utils
 36 | 
 37 | import Paths_expresso
 38 | 
 39 | ps1 :: String
 40 | ps1 = "λ"
 41 | 
 42 | data Mode = SingleLine | MultiLine | Quitting
 43 | 
 44 | data ReplState = ReplState
 45 |   { stateMode    :: Mode
 46 |   , stateBuffer  :: [String]
 47 |   , stateEnv     :: Environments
 48 |   , stateLibDirs :: [FilePath]
 49 |   }
 50 | 
 51 | data Command
 52 |   = Peek      ExpI
 53 |   | Type      ExpI
 54 |   | Load      FilePath
 55 |   | ChangeCWD FilePath
 56 |   | BeginMulti
 57 |   | Reset
 58 |   | DumpEnv
 59 |   | Quit
 60 |   | Help
 61 | 
 62 | data Line
 63 |   = Command Command
 64 |   | Term ExpI
 65 |   | Decl (Bind Name) (Maybe Type) ExpI
 66 |   | TypeDecl SynonymDecl
 67 |   | NoOp
 68 | 
 69 | type Repl = InputT (StateT ReplState IO)
 70 | 
 71 | main :: IO ()
 72 | main = do
 73 |   preludePath <- liftIO $ getDataFileName "Prelude.x"
 74 |   currentDir  <- liftIO getCurrentDirectory
 75 |   let libDirs = [takeDirectory preludePath, currentDir]
 76 |   runRepl libDirs $ do
 77 |     mapM_ spew
 78 |       [ unwords ["Expresso", showVersion version, "REPL"]
 79 |       , "Type :help or :h for a list of commands"
 80 |       ]
 81 |     HL.catch
 82 |         (loadPrelude preludePath)
 83 |         (\(e :: HL.SomeException) ->
 84 |              spew $ "Warning: Couldn't open " ++ preludePath ++ ": " ++ show e)
 85 |     repl
 86 | 
 87 | -- | The read-eval-print-loop
 88 | repl :: Repl ()
 89 | repl = step repl
 90 |        `HL.catch` (\(e :: HL.SomeException) -> spew (show e) >> repl)
 91 |   where
 92 |     step :: Repl () -> Repl ()
 93 |     step cont = HL.withInterrupt $ do
 94 |       mode <- lift $ gets stateMode
 95 |       case mode of
 96 |         MultiLine  -> do
 97 |           minput <- HL.getInputLine $ ps1 ++ "| "
 98 |           whenJust minput $ \input ->
 99 |               if isEndMulti input
100 |                 then doEndMulti
101 |                 else lift $ modify (addToBuffer input)
102 |           cont
103 |         SingleLine -> do
104 |           minput <- HL.getInputLine $ ps1 ++ "> "
105 |           whenJust minput process
106 |           cont
107 |         Quitting   -> do
108 |           spew "Goodbye."
109 |           return ()
110 | 
111 | process :: String -> Repl ()
112 | process str = do
113 |   case parseLine str of
114 |     Left err              -> spew err
115 |     Right (Command c)     -> doCommand c
116 |     Right (Term e)        -> doEval showValue' e
117 |     Right (Decl b mty e)  -> doDecl b mty e
118 |     Right (TypeDecl syn)  -> doTypeDecl syn
119 |     Right NoOp            -> return ()
120 |  `HL.catch` handler
121 |   where
122 |     handler :: HL.SomeException -> Repl ()
123 |     handler ex = spew $ "Caught exception: " ++ show ex
124 | 
125 | runRepl :: [FilePath] -> Repl a -> IO a
126 | runRepl libDirs m = do
127 |     historyFile <- (</> ".expresso_history") <$> getHomeDirectory
128 |     let settings = HL.defaultSettings {HL.historyFile = Just historyFile}
129 |     evalStateT (HL.runInputT settings m) (emptyReplState libDirs)
130 | 
131 | emptyReplState :: [FilePath] -> ReplState
132 | emptyReplState libDirs = ReplState
133 |   { stateMode    = SingleLine
134 |   , stateBuffer  = mempty
135 |   , stateEnv     = setLibDirs libDirs initEnvironments
136 |   , stateLibDirs = libDirs
137 |   }
138 | 
139 | loadPrelude :: FilePath -> Repl ()
140 | loadPrelude path = do
141 |   spew $ "Loading Prelude from " ++ path
142 |   doLoad path
143 | 
144 | doCommand :: Command -> Repl ()
145 | doCommand c = case c of
146 |   Peek e         -> doEval (return . showValue) e
147 |   Type e         -> doTypeOf e
148 |   Load path      -> doLoad path
149 |   ChangeCWD path -> liftIO $ setCurrentDirectory path
150 |   Quit           -> lift $ modify (setMode Quitting)
151 |   BeginMulti     -> lift $ modify (setMode MultiLine)
152 |   Reset          -> doReset
153 |   DumpEnv        -> doDumpEnv
154 |   Help           -> mapM_ spew
155 |     [ "REPL commands available from the prompt:"
156 |     , ""
157 |     , "<expression>                evaluate an expression"
158 |     , ":peek <expression>          evaluate, but not deeply"
159 |     , ":load <filename>            import record expression as a module"
160 |     , ":{\\n ..lines.. \\n:}\\n       multiline command"
161 |     , ":cd <path>                  change current working directory"
162 |     , ":type <term>                show the type of <term>"
163 |     , ":reset                      reset REPL, unloading all definitions"
164 |     , ":env                        dump bound symbols in the environment"
165 |     , ":quit                       exit REPL"
166 |     , ":help                       display this list of commands"
167 |     , ""
168 |     ]
169 | 
170 | doEval :: (Value -> IO String) -> ExpI -> Repl ()
171 | doEval pp e = do
172 |   envs <- lift $ gets stateEnv
173 |   v'e  <- liftIO $ evalWithEnv envs e
174 |   case v'e of
175 |       Left err  -> spew err
176 |       Right val -> liftIO (pp val) >>= spew
177 | 
178 | doLoad :: FilePath -> Repl ()
179 | doLoad path =
180 |   doDecl RecWildcard Nothing
181 |        $ Fix (InR (K (Import path)) :*: K dummyPos)
182 | 
183 | doDecl :: Bind Name -> Maybe Type -> ExpI -> Repl ()
184 | doDecl b mty e = do
185 |   envs   <- lift $ gets stateEnv
186 |   envs'e <- liftIO $ runEvalM $ bind envs b mty e
187 |   case envs'e of
188 |       Left err    -> spew err
189 |       Right envs' -> lift $ modify (setEnv envs')
190 | 
191 | doTypeDecl :: SynonymDecl -> Repl ()
192 | doTypeDecl syn = do
193 |   envs <- lift $ gets stateEnv
194 |   let envs'e = runExcept
195 |              . installSynonyms [syn]
196 |              . uninstallSynonym syn
197 |              $ envs
198 |   case envs'e of
199 |       Left err    -> spew err
200 |       Right envs' -> lift $ modify (setEnv envs')
201 | 
202 | doTypeOf :: ExpI -> Repl ()
203 | doTypeOf e = do
204 |     envs <- lift $ gets stateEnv
205 |     ms   <- liftIO $ typeOfWithEnv envs e
206 |     case ms of
207 |       Left err    -> spew err
208 |       Right sigma -> spew (showType sigma)
209 | 
210 | doReset :: Repl ()
211 | doReset = lift $ do
212 |     libDirs <- gets stateLibDirs
213 |     modify (setEnv $ setLibDirs libDirs initEnvironments)
214 | 
215 | doDumpEnv :: Repl ()
216 | doDumpEnv = do
217 |   envs <- lift $ gets stateEnv
218 |   forM_ (dumpTypeEnv envs) $ \(name, sigma) ->
219 |       spew $ name ++ " : " ++ showType sigma
220 | 
221 | parseLine :: String -> Either String Line
222 | parseLine str
223 |   | all isSpace str = return NoOp
224 |   | otherwise = showError $ P.parse (topLevel pLine) "<interactive>" str
225 | 
226 | pLine :: Parser Line
227 | pLine = pCommand <|> P.try pTerm <|> pDecl <|> pTypeDecl
228 | 
229 | pTerm :: Parser Line
230 | pTerm = Term <$> pExp
231 | 
232 | pDecl :: Parser Line
233 | pDecl = (\(b, mt, e) -> Decl b mt e)
234 |     <$> (reserved "let" *> pLetDecl)
235 | 
236 | pTypeDecl :: Parser Line
237 | pTypeDecl = TypeDecl <$> pSynonymDecl
238 | 
239 | pCommand :: Parser Line
240 | pCommand = Command <$> (reservedOp ":" *> p)
241 |   where
242 |     p =  (reserved "peek"  <|> reserved "p") *> (Peek      <$> pExp)
243 |      <|> (reserved "type"  <|> reserved "t") *> (Type      <$> pExp)
244 |      <|> (reserved "load"  <|> reserved "l") *> (Load      <$> pFilePath)
245 |      <|> reserved "cd"                       *> (ChangeCWD <$> pFilePath)
246 |      <|> (reserved "reset" <|> reserved "r") *> pure Reset
247 |      <|> (reserved "env"   <|> reserved "e") *> pure DumpEnv
248 |      <|> (reserved "quit"  <|> reserved "q") *> pure Quit
249 |      <|> (reserved "help"
250 |           <|> reserved "h" <|> reserved "?") *> pure Help
251 |      <|> reserved "{"                        *> pure BeginMulti
252 | 
253 | pFilePath :: Parser FilePath
254 | pFilePath = stringLiteral -- TODO
255 | 
256 | setMode :: Mode -> ReplState -> ReplState
257 | setMode m s = s { stateMode = m }
258 | 
259 | setEnv :: Environments -> ReplState -> ReplState
260 | setEnv envs s = s { stateEnv = envs }
261 | 
262 | addToBuffer :: String -> ReplState -> ReplState
263 | addToBuffer str s = s { stateBuffer = stateBuffer s ++ [str] }
264 | 
265 | doEndMulti :: Repl ()
266 | doEndMulti = do
267 |   str <- lift $ gets (unlines . stateBuffer)
268 |   lift $ modify $ clearBuffer . setMode SingleLine
269 |   process str
270 | 
271 | clearBuffer :: ReplState -> ReplState
272 | clearBuffer s = s { stateBuffer = mempty }
273 | 
274 | isEndMulti :: String -> Bool
275 | isEndMulti ":}" = True
276 | isEndMulti _    = False
277 | 
278 | spew :: String -> Repl ()
279 | spew = HL.outputStrLn
280 | 
281 | whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
282 | whenJust mg f = maybe (pure ()) f mg
283 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # ☕ Expresso
  2 | 
  3 | A simple expressions language with polymorphic extensible row types.
  4 | 
  5 | 
  6 | ## Introduction
  7 | 
  8 | Expresso is a minimal statically-typed functional programming language, designed with embedding and/or extensibility in mind.
  9 | Possible use cases for such a minimal language include configuration (à la Nix), data exchange (à la JSON) or even a starting point for a custom external DSL.
 10 | 
 11 | Expresso has the following features:
 12 | 
 13 | - A small and simple implementation
 14 | - Statically typed with type inference
 15 | - Structural typing with extensible records and variants
 16 | - Lazy evaluation
 17 | - Convenient use from Haskell (a type class for marshalling values)
 18 | - Whitespace insensitive syntax
 19 | - Type annotations to support first-class modules and schema validation use cases
 20 | - Built-in support for ints, double, bools, chars and lists
 21 | - Support for fixed-points (useful for dynamic binding), but without recursive records.
 22 | 
 23 | ## Installation
 24 | 
 25 | Expresso the library and executable (the REPL) is currently built and tested using cabal.
 26 | 
 27 | ## Functions
 28 | 
 29 | Expresso is a functional language and so we use lambda terms as our basic means of abstraction. To create a named function, we simply bind a lambda using let. I toyed with the idea of using Nix-style lambda syntax, e.g. `x: x` for the identity function, but many mainstream languages, not just Haskell, use an arrow to denote a lambda term. An arrow is also consistent with the notation we use for types.
 30 | Expresso therefore uses the arrow `->` to denote lambdas, with the parameters to bind on the left and the expression body on the right, for example `x -> x` for identity.
 31 | 
 32 | Note that multiple juxtaposed arguments is sugar for currying. For example:
 33 | 
 34 |     f x -> f x
 35 | 
 36 | is the same as:
 37 | 
 38 |     f -> x -> f x
 39 | 
 40 | The function composition operators are `>>` and `<<` for forwards and backwards composition respectively.
 41 | 
 42 | 
 43 | ## Records
 44 | 
 45 | Expresso records are built upon row-types with row extension as the fundamental primitive. This gives a very simple and easy-to-use type system when compared to more advanced systems built upon concatenation as a primitive. However, even in this simple system, concatenation can be encoded quite easily using difference records.
 46 | 
 47 | Records can of course contain arbitrary types and be arbitrarily nested. They can also be compared for equality. The dot operator (select) is used to project out values.
 48 | 
 49 |     Expresso REPL
 50 |     Type :help or :h for a list of commands
 51 |     Loaded Prelude from /home/tim/Expresso/Prelude.x
 52 |     λ> {x = 1}.x
 53 |     1
 54 |     λ> {x = {y = "foo"}, z = [1,2,3]}.x.y
 55 |     "foo"
 56 |     λ> {x = 1, y = True} == {y = True, x = 1}
 57 |     True
 58 | 
 59 | Note that records cannot refer to themselves, as Expresso does not support type-level recursion.
 60 | 
 61 | ### Record extension
 62 | 
 63 | Records are eliminated using selection `.` and introduced using extension `|`. For example, the record literal:
 64 | 
 65 |     {x = 1, y = True}
 66 | 
 67 | is really sugar for:
 68 | 
 69 |     {x = 1 | { y = True | {}}}
 70 | 
 71 | The row types use lacks constraints to prohibit overlapping field names. For example, the following is ill-typed:
 72 | 
 73 |     {x = 1, x = 2} -- DOES NOT TYPE CHECK!
 74 | 
 75 |     let r = {x = "foo"} in {x = "bar" | r} -- DOES NOT TYPE CHECK!
 76 | 
 77 | The lacks constraints are shown when printing out inferred row types via the REPL, for example:
 78 | 
 79 |     λ> :type r -> {x = 1 | r}
 80 |     forall r. (r\x) => {r} -> {x : Int | r}
 81 | 
 82 | In the above output, the REPL reports that this lambda can take a record with underlying row-type `r`, providing `r` satisfies the constraint that it does not have a field `x`.
 83 | 
 84 | The type of a literal record is *closed*, in that the set of fields is fully known:
 85 | 
 86 |     λ> :type {x = 1}
 87 |     {x : Int}
 88 | 
 89 | However, we permit records with redundant fields as arguments to functions, by inferring *open* record types:
 90 | 
 91 |     λ> let sqmag = {x, y} -> x*x + y*y
 92 |     λ> :type sqmag
 93 |     forall a r. (Num a, r\x\y) => {x : a, y : a | r} -> a
 94 | 
 95 | An open record type is indicated by a row-type in the tail of the record.
 96 | 
 97 | Note that the function definition for `sqmag` above makes use of field punning. We could have alternatively written:
 98 | 
 99 |     λ> let sqmag = r -> r.x*r.x + r.y*r.y
100 | 
101 | When matching on record arguments, sometimes it can be necessary to supply a new name to bind the values of a field to, for example:
102 | 
103 |     λ> let add = {x=r, y=s} {x=u, y=v} -> {x = r + u, y = s + v}
104 | 
105 | ### Record restriction
106 | 
107 | We can remove a field by using the restriction primitive `\`. For example, the following will type-check:
108 | 
109 |     {x = 1 | {x = 2}\x}
110 | 
111 | We can also use the following syntactic sugar, for such an override:
112 | 
113 |     {x := 1 | {x = 1}}
114 | 
115 | ### First-class modules
116 | 
117 | Records can be used as a simple but powerful module system. For example, imagine a module `"List.x"` with derived operations on lists:
118 | 
119 |     let
120 |         reverse     = foldl (xs x -> x :: xs) [];
121 |         intercalate = xs xss -> concat (intersperse xs xss);
122 |         ...
123 | 
124 |     -- Exports
125 |     in { reverse
126 |        , intercalate
127 |        , ...
128 |        }
129 | 
130 | Such a module can be imported using a `let` declaration:
131 | 
132 |     λ> let list = import "List.x"
133 |     λ> :type list.intercalate
134 |     forall a. [a] -> [[a]] -> [a]
135 | 
136 | Or simply:
137 | 
138 |     λ> let {..} = import "List.x"
139 | 
140 | Records with polymorphic functions can be passed as lambda arguments and remain polymorphic using *higher-rank polymorphism*. To accomplish this, we must provide Expresso with a suitable type annotation of the argument. For example:
141 | 
142 |     let f = (m : forall a. { reverse : [a] -> [a] |_}) ->
143 |                 {l = m.reverse [True, False], r = m.reverse [1,2,3] }
144 | 
145 | The function `f` above takes a "module" `m` containing a polymorphic function `reverse`. We annotate `m` with a type by using a single colon `:` followed by the type we are expecting.
146 | Note the underscore `_` in the tail of the record. This is a *type wildcard*, meaning we have specified a *partial type signature*. This type wildcard allows us to pass an arbitrary module containing a `reverse` function with this signature. To see the full type signature of `f`, we can use the Expresso REPL:
147 | 
148 |     λ> :t f
149 |     forall r. (r\reverse) => (forall a. {reverse : [a] -> [a] | r}) ->
150 |         {l : [Bool], r : [Int]}
151 | 
152 | Note that the `r`, representing the rest of the module fields, is a top-level quantifier. The type wildcard is especially useful here, as it allows us to avoid creating a top-level signature for the entire function and explicitly naming this row variable. More generally, type wildcards allow us to leave parts of a type signature unspecified.
153 | 
154 | Function `f` can now of course be applied to any module satisfying the type signature:
155 | 
156 |     λ> f (import "List.x")
157 |     {l = [False, True], r = [3,2,1]}
158 | 
159 | 
160 | ### Difference records and concatenation
161 | 
162 | To encode concatenation, we can use functions that extend records and compose them using straightforward function composition:
163 | 
164 |     let f = (r -> { x = "foo", y = True | r}) >> (r -> { z = "bar" | r})
165 | 
166 | Expresso has a special syntax for such "difference records":
167 | 
168 |     λ> let f = {| x = "foo", y = True |} >> {| z = "bar" |}
169 |     λ> f {}
170 |     {z = "bar", x = "foo", y = True}
171 | 
172 | Concatenation is asymmetric whenever we use overrides, for example:
173 | 
174 |      {| x = "foo" |} >> {| x := "bar" |} -- Type checks
175 |      {| x = "foo" |} << {| x := "bar" |} -- DOES NOT TYPE CHECK!
176 | 
177 | ### The Unit type
178 | 
179 | The type `{}` is an example of a *Unit* type. It has only one inhabitant, the empty record `{}`:
180 | 
181 |     λ> :type {}
182 |     {}
183 | 
184 | 
185 | ## Variants
186 | 
187 | The dual of records are variants, which are also polymorphic and extensible since they use the same underlying row-types.
188 | Variants are introduced via injection (the dual of record selection), for example:
189 | 
190 |     λ> Foo 1
191 |     Foo 1
192 | 
193 | Unlike literal records, literal variants are *open*.
194 | 
195 |     λ> :type Foo 1
196 |     forall r. (r\Foo) => <Foo : Int | r>
197 | 
198 | Variants are eliminated using the case construct, for example:
199 | 
200 |     λ> case Foo 1 of { Foo x -> x, Bar{x,y} -> x+y }
201 |     1
202 | 
203 | The above case expression eliminates a *closed* variant, meaning any value other than `Foo` or `Bar` with their expected payloads would lead to a type error. To eliminate an *open* variant, we use a syntax analogous to extension:
204 | 
205 |     λ> let f = x -> case x of { Foo x -> x, Bar{x,y} -> x+y | otherwise -> 42 }
206 |     λ> f (Baz{})
207 |     42
208 | 
209 | Here the unmatched variant is passed to a lambda (with `otherwise` as the parameter). The expression after the bar `|` typically either ignores the variant or delegates it to another function.
210 | 
211 | ### Closed variants
212 | 
213 | We will often need to create closed variant types. For example, we may want to create a structural type analogous to Haskell's `Maybe a`, having only two constructors: `Nothing` and `Just`. This can be accomplished using smart constructors with type annotations. In the Prelude, we define the equivalent constructors `just` and `nothing`, as well as a fold `maybe` over this closed set:
214 | 
215 |     type Maybe a = <Just : a, Nothing : {}>;
216 | 
217 |     just        : forall a. a -> Maybe a
218 |                 = x -> Just x;
219 | 
220 |     nothing     : forall a. Maybe a
221 |                 = Nothing{};
222 | 
223 |     maybe       = b f m -> case m of { Just a -> f a, Nothing{} -> b }
224 | 
225 | Note that we declare and use a type synonym `Maybe a` to avoid repeating the type `<Just : a, Nothing : {}>`. Type synonyms can be included at the top of any file and have global scope.
226 | 
227 | ### Variant embedding
228 | 
229 | The dual of record restriction is variant embedding. This allows us to restrict the behaviour exposed by a case expression, by exploiting the non-overlapping field constraints.
230 | For example, to prevent use of the `Bar` alternative of function `f` above, we can define a new function `g` as follows:
231 | 
232 |     λ> let g = x -> f (<|Bar|> x)
233 |     λ> :type g
234 |     forall r. (r\Bar\Foo) => <Foo : Int | r> -> Int
235 | 
236 | Embedding is used internally to implement overriding alternatives, for example:
237 | 
238 |     λ> let g = x -> case x of { override Foo x -> x + 1 | f }
239 | 
240 | is sugar for:
241 | 
242 |     λ> let g = x -> case x of { Foo x -> x + 1 | <|Foo|> >> f }
243 | 
244 |     λ> :type g
245 |     forall r1 r2. (r1\x\y, r2\Bar\Foo) => <Foo : Int, Bar : {x : Int, y : Int | r1} | r2> -> Int
246 | 
247 | ### The Void type
248 | 
249 | Internally, the syntax to eliminate a closed variant uses the empty variant type `<>`, also known as *Void*. The Void type has no inhabitants, but we can use it to define a function `absurd`:
250 | 
251 |     λ> :type absurd
252 |     forall a. <> -> a
253 | 
254 | Absurd is an example of *Ex Falso Quodlibet* from classical logic (anything can be proven using a contradiction as a premise).
255 | 
256 | As an example of the above, the following closed case expression:
257 | 
258 |     case x of { Foo{} -> 1, Bar{} -> 2 }
259 | 
260 | is actually sugar for:
261 | 
262 |     case x of { Foo{} -> 1 | x' -> case x' of { Bar{} -> 2 | absurd } }
263 | 
264 | 
265 | ## A data-exchange format with schemas
266 | 
267 | We could use Expresso as a lightweight data-exchange format (i.e. JSON with types). But how might we validate terms against a schema?
268 | 
269 | A simple type annotation `<term> : <type>` , will not suffice for "schema validation". For example, consider this attempt at validating an integer against a schema that permits everything:
270 | 
271 |     1 : forall a. a        -- DOES NOT TYPE CHECK!
272 | 
273 | The above fails to type check since the left-hand-side is inferred as the most general type (here a concrete int) and the right-hand-side must be less so.
274 | 
275 | Instead we need something like this:
276 | 
277 |     (id : forall a. a -> a) 1
278 | 
279 | A nice syntactic sugar for this is a *signature section*, although the version in Expresso is slightly different from the Haskell proposal. We write `(:T)` to mean `id : T -> T`, where any quantifiers are kept at the top-level. We can now use:
280 | 
281 |     (: forall a. a) 1
282 | 
283 | If we really do have places in our schema where we want to permit arbitrary data, we should use the equality constraint to guarantee the absence of partially-applied functions. For example:
284 | 
285 |     (: forall a. Eq a => { x : <Foo : Int, Bar : a> }) { x = Bar id }
286 | 
287 | would fail to type check. But the following succeeds:
288 | 
289 |     λ> (: forall a. Eq a => { x : <Foo : Int, Bar : a> }) { x = Bar "abc" }
290 |     {x = Bar "abc"}
291 | 
292 | 
293 | ## Lazy evaluation
294 | 
295 | Expresso uses lazy evaluation in the hope that it might lead to efficiency gains when working with large nested records.
296 | 
297 |     λ> :peek {x = "foo"}
298 |     {x = <Thunk>}
299 | 
300 | 
301 | ## Turing equivalence?
302 | 
303 | Turing equivalence is introduced via a single `fix` primitive, which can be easily removed or disabled.
304 | `fix` can be useful to achieve open recursive records and dynamic binding (à la Nix).
305 | 
306 |     λ> let r = mkOverridable (self -> {x = "foo", y = self.x <> "bar"})
307 |     λ> r
308 |     {override_ = <Lambda>, x = "foo", y = "foobar"}
309 | 
310 |     λ> override r {| x := "baz" |}
311 |     {override_ = <Lambda>, x = "baz", y = "bazbar"}
312 | 
313 | Note that removing `fix` and Turing equivalence does not guarantee termination in practice. It is still possible to write exponential programs that will not terminate during the lifetime of the universe without recursion or fix.
314 | 
315 | ## A configuration file format
316 | 
317 | Expresso can be used as a typed configuration file format from within Haskell programs. As an example, let's consider a hypothetical small config file for a backup program:
318 | 
319 |     let awsTemplate =
320 |         { location ="s3://s3-eu-west-1.amazonaws.com/tim-backup"
321 |         , include  = []
322 |         , exclude  = []
323 |         }
324 |     in
325 |     { cachePath   = Default{}
326 |     , taskThreads = Override 2
327 |     , profiles =
328 |        [ { name = "pictures"
329 |          , source = "~/Pictures"
330 |          | awsTemplate
331 |          }
332 |        , { name = "music"
333 |          , source = "~/Music"
334 |          , exclude := ["**/*.m4a"]
335 |          | awsTemplate }
336 |        ]
337 |     }
338 | 
339 | Note that even for such a small example, we can already leverage some of the abstraction power of extensible records to avoid repetition in the config file.
340 | 
341 | In order to consume this file from a Haskell program, we can define some corresponding nominal data types:
342 | 
343 |     data Config = Config
344 |         { configCachePath   :: Overridable Text
345 |         , configTaskThreads :: Overridable Integer
346 |         , configProfiles    :: [Profile]
347 |         } deriving Show
348 | 
349 |     data Overridable a = Default | Override a deriving Show
350 | 
351 |     data Profile = Profile
352 |         { profileName     :: Text
353 |         , profileLocation :: Text
354 |         , profileInclude  :: [Text]
355 |         , profileExclude  :: [Text]
356 |         , profileSource   :: Text
357 |         } deriving Show
358 | 
359 | Using the Expresso API, we can write `HasValue` instances to handle the projection into and injection from, Haskell values:
360 | 
361 |     import Expresso
362 | 
363 |     instance HasValue Config where
364 |         proj v = Config
365 |             <$> v .: "cachePath"
366 |             <*> v .: "taskThreads"
367 |             <*> v .: "profiles"
368 |         inj Config{..} = mkRecord
369 |             [ "cachePath"      .= inj configCachePath
370 |             , "taskThreads"    .= inj configTaskThreads
371 |             , "profiles"       .= inj configProfiles
372 |             ]
373 | 
374 |     instance HasValue a => HasValue (Overridable a) where
375 |         proj = choice [("Override", fmap Override . proj)
376 |                       ,("Default",  const $ pure Default)
377 |                       ]
378 |         inj (Override x) = mkVariant "Override" (inj x)
379 |         inj Default = mkVariant "Default" unit
380 | 
381 |     instance HasValue Profile where
382 |         proj v = Profile
383 |             <$> v .: "name"
384 |             <*> v .: "location"
385 |             <*> v .: "include"
386 |             <*> v .: "exclude"
387 |             <*> v .: "source"
388 |         inj Profile{..} = mkRecord
389 |             [ "name"     .= inj profileName
390 |             , "location" .= inj profileLocation
391 |             , "include"  .= inj profileInclude
392 |             , "exclude"  .= inj profileExclude
393 |             , "source"   .= inj profileSource
394 |             ]
395 | 
396 | Before we load the config file, we will probably want to check the inferred types against an agreed signature (a.k.a. schema validation). The Expresso API provides a Template Haskell quasi-quoter to make this convenient from within Haskell:
397 | 
398 |     import Expresso.TH.QQ
399 | 
400 |     schema :: Type
401 |     schema =
402 |       [expressoType|
403 |         { cachePath   : <Default : {}, Override : Text>
404 |         , taskThreads : <Default : {}, Override : Int>
405 |         , profiles :
406 |             [ { name     : Text
407 |               , location : Text
408 |               , include  : [Text]
409 |               , exclude  : [Text]
410 |               , source   : Text
411 |               }
412 |             ]
413 |         }|]
414 | 
415 | We can thus load, validate and evaluate the above config file using the following code:
416 | 
417 |     loadConfig :: FilePath -> IO (Either String Config)
418 |     loadConfig = evalFile (Just schema)
419 | 
420 | Note that we can also install our own custom values/functions for users to reference in their config files. For example:
421 | 
422 |     loadConfig :: FilePath -> IO (Either String Config)
423 |     loadConfig = evalFile' envs (Just schema)
424 |       where
425 |         envs = installBinding "system" TText (inj System.Info.os)
426 |              . installBinding "takeFileName"  (TFun TText TText) (inj takeFileName)
427 |              . installBinding "takeDirectory" (TFun TText TText) (inj takeDirectory)
428 |              . installBinding "doesPathExist" (TFun TText TBool) (inj doesPathExist) -- NB: This does IO reads
429 |              $ initEnvironments
430 | 
431 | Finally, we need not limit ourselves to config files that specify record values. We can project Expresso function values into Haskell functions (in IO), allowing higher-order config files! The projection itself is handled by the `HasValue` class, just like any other value:
432 | 
433 |      Haskell> Right (f :: Integer -> IO Integer) <- evalString (Just $ TFun TInt TInt) "x -> x + 1"
434 |      Haskell> f 1
435 |      2
436 | 
437 | ## References
438 | 
439 | Expresso is built upon many ideas described in the following publications:
440 | * "Practical type inference for arbitrary-rank types" Peyton-Jones et al. 2011.
441 | * "A Polymorphic Type System for Extensible Records and Variants" B. R. Gaster and M. P. Jones, 1996.
442 | * "Extensible records with scoped labels" D. Leijen, 2005.
443 | 


--------------------------------------------------------------------------------
/src/Expresso/Type.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveDataTypeable #-}
  2 | {-# LANGUAGE DeriveFoldable #-}
  3 | {-# LANGUAGE DeriveFunctor #-}
  4 | {-# LANGUAGE DeriveTraversable #-}
  5 | {-# LANGUAGE FlexibleContexts #-}
  6 | {-# LANGUAGE FlexibleInstances #-}
  7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  8 | {-# LANGUAGE MultiParamTypeClasses #-}
  9 | {-# LANGUAGE OverloadedStrings #-}
 10 | {-# LANGUAGE PatternGuards #-}
 11 | {-# LANGUAGE PatternSynonyms #-}
 12 | {-# LANGUAGE RecordWildCards #-}
 13 | {-# LANGUAGE TupleSections #-}
 14 | {-# LANGUAGE TypeFamilies #-}
 15 | {-# LANGUAGE TypeOperators #-}
 16 | {-# LANGUAGE ViewPatterns #-}
 17 | 
 18 | -- |
 19 | -- Module      : Expresso.Type
 20 | -- Copyright   : (c) Tim Williams 2017-2019
 21 | -- License     : BSD3
 22 | --
 23 | -- Maintainer  : info@timphilipwilliams.com
 24 | -- Stability   : experimental
 25 | -- Portability : portable
 26 | --
 27 | -- The abstract syntax for types in Expresso.
 28 | --
 29 | module Expresso.Type where
 30 | 
 31 | import Control.Monad
 32 | import Control.Monad.Except
 33 | import Data.Data
 34 | import Data.Foldable (fold)
 35 | import Data.IntMap (IntMap)
 36 | import Data.Map (Map)
 37 | import Data.Maybe
 38 | import Data.Set (Set)
 39 | import qualified Data.Graph as Graph
 40 | import qualified Data.List as L
 41 | import qualified Data.Map as M
 42 | import qualified Data.Set as S
 43 | import qualified Data.Tree as Tree
 44 | import qualified Data.IntMap as IM
 45 | 
 46 | import Text.Parsec (SourcePos)
 47 | import Text.Parsec.Pos (newPos)
 48 | 
 49 | import Expresso.Pretty
 50 | import Expresso.Utils
 51 | 
 52 | -- | Source position
 53 | type Pos   = SourcePos
 54 | 
 55 | -- | Row label
 56 | type Label = String
 57 | 
 58 | -- | A string representing a unique name.
 59 | type Name  = String
 60 | 
 61 | -- | Type syntax annotated with source position.
 62 | type Type  = Fix (TypeF :*: K Pos)
 63 | 
 64 | -- | Unannotated type syntax.
 65 | type Type' = Fix TypeF
 66 | 
 67 | type Sigma = Type
 68 | type Rho   = Type  -- No top-level ForAll
 69 | type Tau   = Type  -- No ForAlls anywhere
 70 | 
 71 | -- | Pattern functor for the syntax of types.
 72 | data TypeF r
 73 |   = TForAllF  [TyVar] r
 74 |   | TVarF     TyVar
 75 |   | TMetaVarF MetaTv
 76 |   | TSynonymF Name [r]
 77 |   | TIntF
 78 |   | TDblF
 79 |   | TBoolF
 80 |   | TCharF
 81 |   | TTextF
 82 |   | TFunF r r
 83 |   | TListF r
 84 |   | TRecordF r
 85 |   | TVariantF r
 86 |   | TRowEmptyF
 87 |   | TRowExtendF Label r r
 88 |   deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Typeable, Data)
 89 | 
 90 | type Uniq = Int
 91 | 
 92 | data Flavour
 93 |   = Bound    -- a type variable bound by a ForAll
 94 |   | Skolem   -- a skolem constant
 95 |   | Wildcard -- a type wildcard
 96 |   deriving (Eq, Ord, Show, Typeable, Data)
 97 | 
 98 | data TyVar = TyVar
 99 |   { tyvarFlavour    :: Flavour
100 |   , tyvarName       :: Name
101 |   , tyvarPrefix     :: Char -- used to generate names
102 |   , tyvarConstraint :: Constraint
103 |   } deriving (Eq, Ord, Show, Typeable, Data)
104 | 
105 | data MetaTv = MetaTv  -- can unify with any tau-type
106 |   { metaUnique      :: Uniq
107 |   , metaPrefix      :: Char -- used to generate names
108 |   , metaConstraint  :: Constraint
109 |   } deriving (Eq, Ord, Show, Typeable, Data)
110 | 
111 | -- | Type variable constraints
112 | -- e.g. for types of kind row, labels the associated tyvar must lack
113 | data Constraint
114 |   = CNone
115 |   | CRow  (Set Label)
116 |   | CStar StarHierarchy
117 |   deriving (Eq, Ord, Show, Typeable, Data)
118 | 
119 | -- | A simple hierarchy. i.e. Num has Ord and Eq, Ord has Eq.
120 | data StarHierarchy
121 |   = CEq
122 |   | COrd
123 |   | CNum
124 |   deriving (Eq, Ord, Show, Typeable, Data)
125 | 
126 | -- | The type environment.
127 | newtype TypeEnv = TypeEnv { unTypeEnv :: Map Name Sigma }
128 |   deriving (Semigroup, Monoid)
129 | 
130 | insertTypeEnv :: Name -> Sigma -> TypeEnv -> TypeEnv
131 | insertTypeEnv name ty (TypeEnv m) = TypeEnv $ M.insert name ty m
132 | 
133 | typeEnvToList :: TypeEnv -> [(Name, Sigma)]
134 | typeEnvToList (TypeEnv m) = M.toList m
135 | 
136 | -- | Global map of type synonym definitions.
137 | newtype Synonyms = Synonyms { unSynonym :: Map Name SynonymDecl }
138 |   deriving (Semigroup, Monoid)
139 | 
140 | -- | A type synonym definition.
141 | data SynonymDecl = SynonymDecl
142 |     { synonymPos    :: Pos
143 |     , synonymName   :: Name
144 |     , synonymParams :: [TyVar]
145 |     , synonymBody   :: Type
146 |     } deriving (Show, Typeable, Data)
147 | 
148 | -- | Lookup and expand a type synonym.
149 | -- Returns Nothing if the lookup or expansion failed.
150 | lookupSynonym :: Name -> [Type] -> Synonyms -> Maybe Sigma
151 | lookupSynonym name args (Synonyms m) = do
152 |     SynonymDecl{..} <- M.lookup name m
153 |     guard $ length synonymParams == length args
154 |     return $ substTyVar synonymParams args synonymBody
155 | 
156 | -- | Used by the REPL.
157 | deleteSynonym :: Name -> Synonyms -> Synonyms
158 | deleteSynonym name (Synonyms m) =
159 |     Synonyms $ M.delete name m
160 | 
161 | -- | Checks for duplicate synonym names, loops/cycles and free variables.
162 | insertSynonyms
163 |     :: MonadError String m
164 |     => [SynonymDecl]
165 |     -> Synonyms
166 |     -> m Synonyms
167 | insertSynonyms ss (Synonyms m) = do
168 |     m' <- foldM f m ss
169 |     case findLoops m' of
170 |         ([],[]) -> return $ Synonyms m'
171 |         (selfLoops,loops) ->
172 |             throwError . unlines $
173 |             [ "Recursive synonym definitions are not supported: " <> loop
174 |             | loop    <- selfLoops
175 |             ] ++
176 |             [ "Mutually recursive synonym definitions are not supported: " <> L.intercalate "," nms
177 |             | nms <- loops
178 |             ]
179 |   where
180 |     f m syn
181 |         | Just syn' <- M.lookup (synonymName syn) m
182 |         -- check that it's not a benign re-import of the same synonym
183 |         , fields syn /= fields syn' =
184 |             throwError $ unwords
185 |                 [ "Duplicate synonyms with name"
186 |                 , "'" ++ synonymName syn ++ "'"
187 |                 , "at"
188 |                 , show syn --(synonymPos syn)
189 |                 , "and"
190 |                 , show syn' -- (synonymPos syn')
191 |                 ]
192 |         | fvs <- ftv (synonymBody syn)
193 |             S.\\ S.fromList (synonymParams syn)
194 |         , not (S.null fvs) =
195 |             throwError $ unwords
196 |                 [ "Free variables in type synonym definition:"
197 |                 , "'" ++ synonymName syn ++ "'"
198 |                 , "at"
199 |                 , show (synonymPos syn)
200 |                 ]
201 |         | otherwise = return $ M.insert (synonymName syn) syn m
202 | 
203 |     -- strip positional annotations
204 |     fields (SynonymDecl _ name vars body) = (name, vars, stripAnn body)
205 | 
206 |     -- Find loops in the graphs (recursive synonyms are not allowed).
207 |     findLoops m = (selfLoops, loops)
208 |       where
209 |         -- Find self-loops
210 |         selfLoops = mapMaybe ((`M.lookup` vertexToName) . fst)
211 |                   . filter (uncurry (==))
212 |                   $ edges
213 | 
214 |         -- We look for all the strongly connected components that
215 |         -- are not singleton lists.
216 |         loops  = mapMaybe (mapM (`M.lookup` vertexToName))
217 |                . filter ((>1) . length)
218 |                . map Tree.flatten
219 |                . Graph.scc
220 |                . Graph.buildG (0, M.size m)
221 |                $ edges
222 | 
223 |         edges = [ (v1, v2) -- edge
224 |                 | (nm, v1) <- M.toList nameToVertex
225 |                 , nm'      <- maybe [] (S.toList . namesFromBody) $ M.lookup nm m
226 |                 , Just v2  <- [M.lookup nm' nameToVertex]
227 |                 ]
228 | 
229 |         vertexToName = M.fromList $ zip [0..] (M.keys m)
230 |         nameToVertex = M.fromList $ zip (M.keys m) [0..]
231 | 
232 |         namesFromBody = cata alg . stripAnn . synonymBody where
233 |             alg :: TypeF (Set Name) -> Set Name
234 |             alg (TSynonymF n ns) = S.insert n (S.unions ns)
235 |             alg t                = fold t
236 | 
237 | 
238 | instance View TypeF Type where
239 |   proj    = left . unFix
240 |   inj  e  = Fix (e :*: K dummyPos)
241 | 
242 | -- | A useless source position.
243 | dummyPos :: Pos
244 | dummyPos = newPos "<unknown>" 1 1
245 | 
246 | instance View TypeF Type' where
247 |   proj = unFix
248 |   inj  = Fix
249 | 
250 | pattern TForAll vs t       <- (proj -> (TForAllF vs t)) where
251 |   TForAll vs t = inj (TForAllF vs t)
252 | pattern TVar v             <- (proj -> (TVarF v)) where
253 |   TVar v = inj (TVarF v)
254 | pattern TMetaVar v         <- (proj -> (TMetaVarF v)) where
255 |   TMetaVar v = inj (TMetaVarF v)
256 | pattern TSynonym v ts      <- (proj -> (TSynonymF v ts)) where
257 |   TSynonym v ts = inj (TSynonymF v ts)
258 | pattern TInt               <- (proj -> TIntF) where
259 |   TInt = inj TIntF
260 | pattern TDbl               <- (proj -> TDblF) where
261 |   TDbl = inj TDblF
262 | pattern TBool              <- (proj -> TBoolF) where
263 |   TBool = inj TBoolF
264 | pattern TChar              <- (proj -> TCharF) where
265 |   TChar = inj TCharF
266 | pattern TText              <- (proj -> TTextF) where
267 |   TText = inj TTextF
268 | pattern TFun t1 t2         <- (proj -> (TFunF t1 t2)) where
269 |   TFun t1 t2 = inj (TFunF t1 t2)
270 | pattern TList t            <- (proj -> (TListF t)) where
271 |   TList t = inj (TListF t)
272 | pattern TRecord t          <- (proj -> (TRecordF t)) where
273 |   TRecord t = inj (TRecordF t)
274 | pattern TVariant t         <- (proj -> (TVariantF t)) where
275 |   TVariant t = inj (TVariantF t)
276 | pattern TRowEmpty          <- (proj -> TRowEmptyF) where
277 |   TRowEmpty = inj TRowEmptyF
278 | pattern TRowExtend l t1 t2 <- (proj -> (TRowExtendF l t1 t2)) where
279 |   TRowExtend l t1 t2 = inj (TRowExtendF l t1 t2)
280 | 
281 | class Types a where
282 |   -- | Free type variables
283 |   ftv   :: a -> Set TyVar
284 | 
285 |   -- | Meta type variables
286 |   meta  :: a -> Set MetaTv
287 | 
288 |   -- | Replace meta type variables with types
289 |   apply :: Subst -> a -> a
290 | 
291 | instance Types Type where
292 |   ftv = cata alg . stripAnn where
293 |     alg :: TypeF (Set TyVar) -> Set TyVar
294 |     alg (TForAllF vs t) = t S.\\ S.fromList vs
295 |     alg (TVarF v)       = S.singleton v
296 |     alg e               = fold e
297 | 
298 |   meta = cata alg . stripAnn where
299 |     alg :: TypeF (Set MetaTv) -> Set MetaTv
300 |     alg (TMetaVarF v) = S.singleton v
301 |     alg e             = fold e
302 | 
303 |   apply s t = cata alg t where
304 |     alg :: (TypeF :*: K Pos) Type -> Type
305 |     alg (TMetaVarF v :*: K p) =
306 |         case IM.lookup (metaUnique v) (unSubst s) of
307 |             Nothing -> Fix (TMetaVarF v :*: K p)
308 |             Just t  -> apply s t -- TODO could this ever fail to terminate?
309 |     alg e = Fix e
310 | 
311 | instance Types TypeEnv where
312 |   ftv (TypeEnv env)  = ftv (M.elems env)
313 |   meta (TypeEnv env) = meta (M.elems env)
314 |   apply s (TypeEnv env) = TypeEnv (M.map (apply s) env)
315 | 
316 | instance Types a => Types [a] where
317 |   ftv  = foldMap ftv
318 |   meta = foldMap meta
319 |   apply s = map (apply s)
320 | 
321 | -- | Get all the binders used in ForAlls in the type, so that
322 | -- when quantifying an outer forall, we can avoid these inner ones.
323 | tyVarBndrs :: Type -> Set TyVar
324 | tyVarBndrs = cata alg . stripAnn where
325 |     alg :: TypeF (Set TyVar) -> Set TyVar
326 |     alg (TForAllF vs t) = t <> S.fromList vs
327 |     alg (TFunF arg res) = arg <> res
328 |     alg _               = S.empty
329 | 
330 | -- Use to instantiate TyVars
331 | substTyVar :: [TyVar] -> [Type] -> Type -> Type
332 | substTyVar tvs ts t = cata alg t m where
333 |   alg :: (TypeF :*: K Pos) (Map Name Type -> Type)
334 |       -> Map Name Type
335 |       -> Type
336 |   alg (TForAllF vs f :*: K p) m  =
337 |       let m' = foldr (M.delete . tyvarName) m vs
338 |       in Fix (TForAllF vs (f m') :*: K p)
339 |   alg (TVarF v :*: K p) m =
340 |         fromMaybe (Fix (TVarF v :*: K p))
341 |             $ M.lookup (tyvarName v) m
342 |   alg e m = Fix $ fmap ($m) e
343 | 
344 |   m = M.fromList $ map tyvarName tvs `zip` ts
345 | 
346 | newtype Subst = Subst { unSubst :: IntMap Type }
347 |   deriving (Show)
348 | 
349 | nullSubst :: Subst
350 | nullSubst = Subst IM.empty
351 | 
352 | infixr 0 |->
353 | (|->) :: MetaTv -> Type -> Subst
354 | (|->) v t = Subst $ IM.singleton (metaUnique v) t
355 | 
356 | isInSubst :: MetaTv -> Subst -> Bool
357 | isInSubst v = IM.member (metaUnique v) . unSubst
358 | 
359 | removeFromSubst :: [MetaTv] -> Subst -> Subst
360 | removeFromSubst vs (Subst m) =
361 |     Subst $ foldr (IM.delete . metaUnique) m vs
362 | 
363 | -- | apply s1 and then s2
364 | -- NB: order is important
365 | composeSubst :: Subst -> Subst -> Subst
366 | composeSubst s1 s2 = Subst $ IM.map (apply s1) (unSubst s2) `IM.union` unSubst s1
367 | 
368 | instance Semigroup Subst where
369 |     (<>) = composeSubst
370 | 
371 | instance Monoid Subst where
372 |     mempty = nullSubst
373 | 
374 | --  | decompose a row-type into its constituent parts
375 | toList :: Type -> ([(Label, Type)], Maybe Type)
376 | toList v@TVar{}           = ([], Just v)
377 | toList v@TMetaVar{}       = ([], Just v)
378 | toList TRowEmpty          = ([], Nothing)
379 | toList (TRowExtend l t r) =
380 |     let (ls, mv) = toList r
381 |     in ((l, t):ls, mv)
382 | toList t = error $ "Unexpected row type: " ++ show (ppType t)
383 | 
384 | extractMetaTv :: Type -> Maybe MetaTv
385 | extractMetaTv (TMetaVar v) = Just v
386 | extractMetaTv _            = Nothing
387 | 
388 | lacks :: [Label] -> Constraint
389 | lacks = CRow . S.fromList
390 | 
391 | mkRowType :: Type -> [(Label, Type)] -> Type
392 | mkRowType = foldr $ \(l, t@(getAnn -> pos)) r ->
393 |     Fix (TRowExtendF l t r :*: K pos)
394 | 
395 | rowToMap :: Type -> Map Name Type
396 | rowToMap (TRowExtend l t r) = M.insert l t (rowToMap r)
397 | rowToMap TRowEmpty          = M.empty
398 | rowToMap TVar{}             = M.empty -- default any row vars to empty row
399 | rowToMap TMetaVar{}         = M.empty
400 | rowToMap t                  = error $ "Unexpected row type: " ++ show (ppType t)
401 | 
402 | 
403 | ------------------------------------------------------------
404 | -- Constraints
405 | 
406 | -- | True if the supplied type of kind Star satisfies the supplied constraint
407 | satisfies :: Synonyms -> Type -> Constraint -> Bool
408 | satisfies syns t c =
409 |     case (infer t, c) of
410 |         (CNone,    CNone)    -> True
411 |         (CStar{},  CNone)    -> True
412 |         (CNone,    CStar{})  -> False
413 |         (CStar c1, CStar c2) -> c1 >= c2
414 |         (c1, c2)  -> error $ "satisfies: kind mismatch: " ++ show (c1, c2)
415 |   where
416 |     infer :: Type -> Constraint
417 |     infer (TForAll _ t)   = infer t
418 |     infer (TVar     v)    = tyvarConstraint v
419 |     infer (TMetaVar m)    = metaConstraint m
420 |     infer (TSynonym n ts) =
421 |         maybe CNone infer $ lookupSynonym n ts syns
422 |     infer TInt            = CStar CNum
423 |     infer TDbl            = CStar CNum
424 |     infer TBool           = CStar COrd
425 |     infer TChar           = CStar COrd
426 |     infer TText           = CStar COrd
427 |     infer TFun{}          = CNone
428 |     infer (TList t)       = minC (CStar COrd) $ infer t
429 |     infer (TRecord r)     = -- NB: unit supports equality
430 |         maybe (CStar CEq) (minC (CStar CEq)) $ inferFromRow r
431 |     infer (TVariant r)    = -- NB: void does not support equality
432 |         maybe CNone (minC (CStar CEq)) $ inferFromRow r
433 |     infer t = error $ "satisfies/infer: unexpected type: " ++ show t
434 | 
435 |     -- infer star constraints from row types
436 |     inferFromRow :: Type -> Maybe Constraint
437 |     inferFromRow TVar{}     = Nothing
438 |     inferFromRow TMetaVar{} = Nothing
439 |     inferFromRow (TSynonym n ts) =
440 |         lookupSynonym n ts syns >>= inferFromRow
441 |     inferFromRow TRowEmpty  = Nothing
442 |     inferFromRow (TRowExtend _ t r) = Just $
443 |         maybe (infer t) (minC (infer t)) $ inferFromRow r
444 |     inferFromRow t =
445 |         error $ "satisfies/inferFromRow: unexpected type: " ++ show t
446 | 
447 |     minC (CStar c1) (CStar c2) = CStar $ min c1 c2
448 |     minC CNone      _          = CNone
449 |     minC _          CNone      = CNone
450 |     minC _          _          = error "minC: assertion failed"
451 | 
452 | -- | unions constraints
453 | -- for kind Star: picks the most specific, i.e. max c1 c2
454 | -- for kind Row: unions the sets of lacks labels
455 | unionConstraints :: Constraint -> Constraint -> Constraint
456 | unionConstraints CNone      c          = c
457 | unionConstraints c          CNone      = c
458 | unionConstraints (CRow s1)  (CRow s2)  = CRow  $ s1 `S.union` s2
459 | unionConstraints (CStar c1) (CStar c2) = CStar $ max c1 c2
460 | unionConstraints c1 c2  = error $ "unionConstraints: kind mismatch: " ++ show (c1, c2)
461 | 
462 | 
463 | ------------------------------------------------------------
464 | -- Pretty-printing
465 | 
466 | type Precedence = Int
467 | 
468 | topPrec, arrPrec, tcPrec, atomicPrec :: Precedence
469 | topPrec    = 0  -- Top-level precedence
470 | arrPrec    = 1  -- Precedence of (a->b)
471 | tcPrec     = 2  -- Precedence of (T a b)
472 | atomicPrec = 3  -- Precedence of t
473 | 
474 | precType :: Type -> Precedence
475 | precType (TForAll _ _)  = topPrec
476 | precType (TFun _ _)     = arrPrec
477 | precType (TSynonym _ ts)
478 |     | null ts           = atomicPrec
479 |     | otherwise         = tcPrec
480 | precType _              = atomicPrec
481 | 
482 | -- | Print with parens if precedence arg > precedence of type itself
483 | ppType' :: Precedence -> Type -> Doc
484 | ppType' p t
485 |     | p >= precType t = parens (ppType t)
486 |     | otherwise       = ppType t
487 | 
488 | ppType :: Type -> Doc
489 | ppType (TForAll vs t)     = ppForAll (vs, t)
490 | ppType (TVar v)           = text $ tyvarName v
491 | ppType (TMetaVar v)       = "v" <> int (metaUnique v)
492 | ppType (TSynonym n ts)
493 |     | null ts             = text n
494 |     | otherwise           = text n <+> hsep (map (ppType' tcPrec) ts)
495 | ppType TInt               = "Int"
496 | ppType TDbl               = "Double"
497 | ppType TBool              = "Bool"
498 | ppType TChar              = "Char"
499 | ppType TText              = "Text"
500 | ppType (TFun t s)         = ppType' arrPrec t <+> "->" <+> ppType' (arrPrec-1) s
501 | ppType (TList a)          = brackets $ ppType a
502 | ppType (TRecord r)        = braces $ ppRowType r
503 | ppType (TVariant r)       = angles $ ppRowType r
504 | ppType TRowEmpty          = "(||)"
505 | ppType (TRowExtend l a r) = "(|" <> text l <> ":" <> ppType a <> "|" <> ppType r <> "|)"
506 | ppType t = error $ "Unexpected type: " ++ show t
507 | 
508 | ppRowType :: Type -> Doc
509 | ppRowType r = sepBy comma (map ppEntry ls)
510 |            <> maybe mempty (ppRowTail ls) mv
511 |   where
512 |     (ls, mv)       = toList r
513 |     ppRowTail [] v = ppType v
514 |     ppRowTail _  v = mempty <+> "|" <+> ppType v
515 |     ppEntry (l, t) = text l <+> ":" <+> ppType t
516 | 
517 | ppRowLabels :: Type -> Doc
518 | ppRowLabels row =
519 |     hcat $ map squotes (L.intersperse comma (map text . M.keys . rowToMap $ row))
520 | 
521 | ppForAll :: ([TyVar], Type) -> Doc
522 | ppForAll (vars, t)
523 |   | null vars = ppType' topPrec t
524 |   | otherwise = "forall" <+> hsep (map (ppType . TVar) vars) <> dot
525 |                          <>  (let cs = concatMap ppConstraint vars
526 |                               in if null cs then mempty else space <> (parensList cs <+> "=>"))
527 |                          <+> ppType' topPrec t
528 |   where
529 |     ppConstraint :: TyVar -> [Doc]
530 |     ppConstraint v =
531 |       case tyvarConstraint v of
532 |         CNone      -> []
533 |         CStar CEq  -> ["Eq"  <+> ppType (TVar v)]
534 |         CStar COrd -> ["Ord" <+> ppType (TVar v)]
535 |         CStar CNum -> ["Num" <+> ppType (TVar v)]
536 |         CRow (S.toList -> ls)
537 |             | null ls   -> []
538 |             | otherwise -> [catBy "\\" $ ppType (TVar v) : map text ls]
539 | 
540 | ppPos :: Pos -> Doc
541 | ppPos = text . show
542 | 
543 | ppStarConstraint :: StarHierarchy -> Doc
544 | ppStarConstraint CEq  = "Eq"
545 | ppStarConstraint COrd = "Ord"
546 | ppStarConstraint CNum = "Num"
547 | 


--------------------------------------------------------------------------------
/src/Expresso/Eval.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts #-}
  2 | {-# LANGUAGE FlexibleInstances #-}
  3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  4 | {-# LANGUAGE LambdaCase #-}
  5 | {-# LANGUAGE OverloadedStrings #-}
  6 | {-# LANGUAGE PatternGuards #-}
  7 | {-# LANGUAGE RankNTypes #-}
  8 | {-# LANGUAGE TypeSynonymInstances #-}
  9 | {-# LANGUAGE TypeOperators #-}
 10 | {-# LANGUAGE ViewPatterns #-}
 11 | {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 12 | 
 13 | -- |
 14 | -- Module      : Expresso.Eval
 15 | -- Copyright   : (c) Tim Williams 2017-2019
 16 | -- License     : BSD3
 17 | --
 18 | -- Maintainer  : info@timphilipwilliams.com
 19 | -- Stability   : experimental
 20 | -- Portability : portable
 21 | --
 22 | -- A lazy evaluator.
 23 | --
 24 | -- The front-end syntax is simple, so we evaluate it directly.
 25 | --
 26 | module Expresso.Eval(
 27 |     Env
 28 |   , EvalM
 29 |   , HasValue(..)
 30 |   , Thunk(..)
 31 |   , Value(..)
 32 |   , bind
 33 |   , choice
 34 |   , eval
 35 |   , insertEnv
 36 |   , mkRecord
 37 |   , mkStrictLam
 38 |   , mkStrictLam2
 39 |   , mkStrictLam3
 40 |   , mkThunk
 41 |   , mkVariant
 42 |   , ppValue
 43 |   , ppValue'
 44 |   , runEvalM
 45 |   , typeMismatch
 46 |   , unit
 47 |   , (.:)
 48 |   , (.=)
 49 | )
 50 | where
 51 | 
 52 | import Control.Monad.Except
 53 | import Data.HashMap.Strict (HashMap)
 54 | import Data.IORef
 55 | import Data.Ord
 56 | import Data.Text (Text)
 57 | import qualified Data.Text as T
 58 | import qualified Data.HashMap.Strict as HashMap
 59 | import qualified Data.List as List
 60 | 
 61 | import Expresso.Syntax
 62 | import Expresso.Type
 63 | import Expresso.Pretty
 64 | import Expresso.Utils (cata, (:*:)(..), K(..))
 65 | 
 66 | -- | A call-by-need environment.
 67 | -- Using a HashMap makes it easy to support record wildcards.
 68 | newtype Env = Env { unEnv :: HashMap Name Thunk } deriving (Semigroup, Monoid)
 69 | 
 70 | type EvalM a = ExceptT String IO a
 71 | 
 72 | -- | A potentially unevaluated value.
 73 | newtype Thunk = Thunk { force :: EvalM Value }
 74 | 
 75 | instance Show Thunk where
 76 |     show _ = "<Thunk>"
 77 | 
 78 | mkThunk :: EvalM Value -> EvalM Thunk
 79 | mkThunk ev = do
 80 |   ref <- liftIO $ newIORef Nothing
 81 |   return $ Thunk $ do
 82 |       mv <- liftIO $ readIORef ref
 83 |       case mv of
 84 |           Nothing -> do
 85 |               v <- ev
 86 |               liftIO $ writeIORef ref (Just v)
 87 |               return v
 88 |           Just v  -> return v
 89 | 
 90 | -- | Type for an evaluated term.
 91 | data Value
 92 |   = VLam     !(Thunk -> EvalM Value)
 93 |   | VInt     !Integer
 94 |   | VDbl     !Double
 95 |   | VBool    !Bool
 96 |   | VChar    !Char
 97 |   | VText    !Text
 98 |   | VList    ![Value] -- lists are strict
 99 |   | VRecord  !(HashMap Label Thunk) -- field order no defined
100 |   | VVariant !Label !Thunk
101 | 
102 | -- | This does *not* evaluate deeply
103 | ppValue :: Value -> Doc
104 | ppValue (VLam  _)   = "<Lambda>"
105 | ppValue (VInt  i)   = integer i
106 | ppValue (VDbl  d)   = double d
107 | ppValue (VBool b)   = if b then "True" else "False"
108 | ppValue (VChar c)   = text $ '\'' : c : '\'' : []
109 | ppValue (VText s)   = string (show $ T.unpack s)
110 | ppValue (VList xs)  = bracketsList $ map ppValue xs
111 | ppValue (VRecord m) = bracesList $ map ppEntry $ HashMap.keys m
112 |   where
113 |     ppEntry l = text l <+> "=" <+> "<Thunk>"
114 | ppValue (VVariant l _) = text l <+> "<Thunk>"
115 | 
116 | -- | This evaluates deeply
117 | ppValue' :: Value -> EvalM Doc
118 | ppValue' (VRecord m) = (bracesList . map ppEntry . HashMap.toList)
119 |                            <$> mapM (force >=> ppValue') m
120 |   where
121 |     ppEntry (l, v) = text l <+> text "=" <+> v
122 | ppValue' (VVariant l t) = (text l <+>) <$> (force >=> ppParensValue) t
123 | ppValue' v = return $ ppValue v
124 | 
125 | ppParensValue :: Value -> EvalM Doc
126 | ppParensValue v =
127 |     case v of
128 |         VVariant{} -> parens <$> ppValue' v
129 |         _          -> ppValue' v
130 | 
131 | extractChar :: Value -> Maybe Char
132 | extractChar (VChar c) = Just c
133 | extractChar _ = Nothing
134 | 
135 | -- | Run the EvalM evaluation computation.
136 | runEvalM :: EvalM a -> IO (Either String a)
137 | runEvalM = runExceptT
138 | 
139 | -- | Partial variant of @runEvalM@.
140 | runEvalM' :: EvalM a -> IO a
141 | runEvalM' = fmap (either error id) . runExceptT
142 | 
143 | eval :: Env -> Exp -> EvalM Value
144 | eval env e = cata alg e env
145 |   where
146 |     alg :: (ExpF Name Bind Type :*: K Pos) (Env -> EvalM Value)
147 |         -> Env
148 |         -> EvalM Value
149 |     alg (EVar v :*: _)            env = lookupValue env v >>= force
150 |     alg (EApp f x :*: K pos)      env = do
151 |         f' <- f env
152 |         x' <- mkThunk (x env)
153 |         evalApp pos f' x'
154 |     alg (ELam b e1 :*: _  )       env = evalLam env b e1
155 |     alg (EAnnLam b _ e1 :*: _)    env = evalLam env b e1
156 |     alg (ELet b e1 e2 :*: _)      env = evalLet env b e1 e2
157 |     alg (EAnnLet b _ e1 e2 :*: _) env = evalLet env b e1 e2
158 |     alg (EPrim p :*: K pos)       _   = return $ evalPrim pos p
159 |     alg (EAnn e _ :*: _)          env = e env
160 | 
161 | evalLam :: Env -> Bind Name -> (Env -> EvalM Value) -> EvalM Value
162 | evalLam env b e = return $ VLam $ \x ->
163 |     bind env b x >>= e
164 | 
165 | evalLet
166 |     :: Env
167 |     -> Bind Name
168 |     -> (Env -> EvalM Value)
169 |     -> (Env -> EvalM Value)
170 |     -> EvalM Value
171 | evalLet env b e1 e2 = do
172 |     t    <- mkThunk $ e1 env
173 |     env' <- bind env b t
174 |     e2 env'
175 | 
176 | evalApp :: Pos -> Value -> Thunk -> EvalM Value
177 | evalApp _   (VLam f)   t  = f t
178 | evalApp pos fv         _  =
179 |     throwError $ show pos ++ " : Expected a function, but got: " ++
180 |                  show (ppValue fv)
181 | 
182 | evalPrim :: Pos -> Prim -> Value
183 | evalPrim pos p = case p of
184 |     Int i         -> VInt i
185 |     Dbl d         -> VDbl d
186 |     Bool b        -> VBool b
187 |     Char c        -> VChar c
188 |     Text s        -> VText s
189 |     Show          -> mkStrictLam $ \v -> VText . T.pack . show <$> ppValue' v
190 |     -- Trace
191 |     ErrorPrim     -> VLam $ \s -> do
192 |         msg <- proj' s
193 |         throwError $ "error (" ++ show pos ++ "): " ++ msg
194 | 
195 |     ArithPrim Add -> mkStrictLam2 $ numOp pos (+)
196 |     ArithPrim Sub -> mkStrictLam2 $ numOp pos (-)
197 |     ArithPrim Mul -> mkStrictLam2 $ numOp pos (*)
198 |     ArithPrim Div -> mkStrictLam2 $ \v1 v2 ->
199 |         case (v1, v2) of
200 |             (VInt x, VInt y) -> return $ VInt $ x `div` y
201 |             (VDbl x, VDbl y) -> return $ VDbl $ x / y
202 |             _                -> failOnValues pos [v1, v2]
203 | 
204 |     RelPrim RGT   -> mkStrictLam2 $ \v1 v2 ->
205 |         (VBool . (==GT)) <$> compareValues pos v1 v2
206 | 
207 |     RelPrim RGTE  -> mkStrictLam2 $ \v1 v2 ->
208 |         (VBool . (`elem` [GT, EQ])) <$> compareValues pos v1 v2
209 | 
210 |     RelPrim RLT   -> mkStrictLam2 $ \v1 v2 ->
211 |         (VBool . (==LT)) <$> compareValues pos v1 v2
212 | 
213 |     RelPrim RLTE  -> mkStrictLam2 $ \v1 v2 ->
214 |         (VBool . (`elem` [LT, EQ])) <$> compareValues pos v1 v2
215 | 
216 |     Eq            -> mkStrictLam2 $ \v1 v2 ->
217 |         VBool <$> equalValues pos v1 v2
218 | 
219 |     NEq           -> mkStrictLam2 $ \v1 v2 ->
220 |         (VBool . not) <$> equalValues pos v1 v2
221 | 
222 |     Not           -> VLam $ \v -> VBool <$> proj' v
223 |     And           -> VLam $ \v1 -> return $ VLam $ \v2 ->
224 |         VBool <$> ((&&) <$> proj' v1 <*> proj' v2)
225 | 
226 |     Or            -> VLam $ \v1 -> return $ VLam $ \v2 ->
227 |         VBool <$> ((||) <$> proj' v1 <*> proj' v2)
228 | 
229 |     Double        -> mkStrictLam $ \v ->
230 |         case v of
231 |             VInt i -> return $ VDbl $ fromInteger i
232 |             _      -> failOnValues pos [v]
233 |     Floor         -> mkStrictLam $ \v ->
234 |         case v of
235 |             VDbl d -> return $ VInt $ floor d
236 |             _      -> failOnValues pos [v]
237 |     Ceiling       -> mkStrictLam $ \v ->
238 |         case v of
239 |             VDbl d -> return $ VInt $ ceiling d
240 |             _      -> failOnValues pos [v]
241 | 
242 |     Neg           -> mkStrictLam $ \v ->
243 |         case v of
244 |             VInt i -> return $ VInt $ negate i
245 |             VDbl d -> return $ VDbl $ negate d
246 |             _      -> failOnValues pos [v]
247 | 
248 |     Mod           -> mkStrictLam $ \v1 -> return $ mkStrictLam $ \v2 ->
249 |         case (v1, v2) of
250 |             (VInt x, VInt y) -> return $ VInt $ x `mod` y
251 |             _                -> failOnValues pos [v1, v2]
252 | 
253 |     Cond     -> VLam $ \c -> return $ VLam $ \t -> return $ VLam $ \f ->
254 |         proj' c >>= \c -> if c then force t else force f
255 |     FixPrim       -> mkStrictLam $ \f -> fix (evalApp pos f <=< mkThunk)
256 | 
257 |     -- We cannot yet define operators like this in the language
258 |     FwdComp       -> mkStrictLam2 $ \f g ->
259 |         return $ VLam $ \x ->
260 |             mkThunk (evalApp pos f x) >>= evalApp pos g
261 |     BwdComp    -> mkStrictLam2 $ \f g ->
262 |         return $ VLam $ \x ->
263 |             mkThunk (evalApp pos g x) >>= evalApp pos f
264 | 
265 |     Pack          -> mkStrictLam $ packChars pos
266 |     Unpack        -> mkStrictLam $ unpackChars pos
267 |     TextAppend    -> VLam $ \xs -> return $ VLam $ \ys ->
268 |         VText <$> ((<>) <$> proj' xs <*> proj' ys)
269 | 
270 |     ListEmpty     -> VList []
271 |     ListCons      -> VLam $ \x -> return $ VLam $ \xs ->
272 |         VList <$> ((:) <$> force x <*> proj' xs)
273 |     ListUncons    -> mkStrictLam $ \case
274 |             VList (x:xs) ->
275 |                 return $ mkVariant "Just" (mkRecord
276 |                                            [ ("head", Thunk $ return x)
277 |                                            , ("tail", Thunk . return $ VList xs)])
278 |             VList []     -> return $ mkVariant "Nothing" unit
279 |             v            -> failOnValues pos [v]
280 |     ListAppend    -> VLam $ \xs -> return $ VLam $ \ys ->
281 |         VList <$> ((++) <$> proj' xs <*> proj' ys)
282 | 
283 |     RecordExtend l   -> VLam $ \v -> return $ VLam $ \r ->
284 |         (VRecord . HashMap.insert l v) <$> proj' r
285 |     RecordRestrict l -> VLam $ \r ->
286 |         (VRecord . HashMap.delete l) <$> proj' r
287 |     RecordSelect l   -> VLam $ \r -> do
288 |         r' <- proj' r
289 |         let err = throwError $ show pos ++ " : " ++ l ++ " not found"
290 |         maybe err force (HashMap.lookup l r')
291 |     RecordEmpty -> VRecord mempty
292 | 
293 |     VariantInject l  -> VLam $ \v ->
294 |         return $ VVariant l v
295 |     VariantEmbed _   -> VLam force
296 |     VariantElim l    -> mkStrictLam $ \f -> return $ mkStrictLam2 $ \k s -> do
297 |         case s of
298 |             VVariant l' t | l==l'     -> evalApp pos f t
299 |                           | otherwise -> evalApp pos k (Thunk $ return s)
300 |             v -> throwError $ show pos ++ " : Expected a variant, but got: " ++
301 |                               show (ppValue v)
302 |     Absurd -> VLam $ \v -> force v >> throwError "The impossible happened!"
303 |     p -> error $ show pos ++ " : Unsupported Prim: " ++ show p
304 | 
305 | -- non-strict bind
306 | bind :: Env -> Bind Name -> Thunk -> EvalM Env
307 | bind env b t = case b of
308 |     Arg n -> return $ insertEnv n t env
309 |     _     -> bind' env b t
310 | 
311 | -- strict bind
312 | bind' :: Env -> Bind Name -> Thunk -> EvalM Env
313 | bind' env b t = do
314 |   v <- force t
315 |   case (b, v) of
316 |     (Arg n, _) ->
317 |         return $ insertEnv n (Thunk $ return v) env
318 |     (RecArg (unzip -> (ls, ns)), VRecord m)
319 |         | Just vs <- mapM (\l -> HashMap.lookup l m) ls ->
320 |           return $ (mkEnv $ zip ns vs) <> env
321 |     (RecWildcard, VRecord m) ->
322 |         return $ Env m <> env
323 |     _ -> throwError $ "Cannot bind the pair: " ++ show b ++ " = " ++ show (ppValue v)
324 | 
325 | insertEnv :: Name -> Thunk -> Env -> Env
326 | insertEnv n t (Env m) = Env $ HashMap.insert n t m
327 | 
328 | lookupEnv :: Name -> Env -> Maybe Thunk
329 | lookupEnv n (Env m) = HashMap.lookup n m
330 | 
331 | mkEnv :: [(Name, Thunk)] -> Env
332 | mkEnv = Env . HashMap.fromList
333 | 
334 | lookupValue :: Env -> Name -> EvalM Thunk
335 | lookupValue env n = maybe err return $ lookupEnv n env
336 |   where
337 |     err = throwError $ "Not found: " ++ show n
338 | 
339 | failOnValues :: Pos -> [Value] -> EvalM a
340 | failOnValues pos vs = throwError $ show pos ++ " : Unexpected value(s) : " ++
341 |                                    show (parensList (map ppValue vs))
342 | 
343 | -- | Make a strict Expresso lambda value (forced arguments) from a
344 | -- Haskell function (on Expresso values).
345 | mkStrictLam :: (Value -> EvalM Value) -> Value
346 | mkStrictLam f = VLam $ \x -> force x >>= f
347 | 
348 | -- | As @mkStrictLam@, but accepts Haskell functions with two curried arguments.
349 | mkStrictLam2 :: (Value -> Value -> EvalM Value) -> Value
350 | mkStrictLam2 f = mkStrictLam $ \v -> return $ mkStrictLam $ f v
351 | 
352 | -- | As @mkStrictLam@, but accepts Haskell functions with three curried arguments.
353 | mkStrictLam3 :: (Value -> Value -> Value -> EvalM Value) -> Value
354 | mkStrictLam3 f = mkStrictLam $ \v -> return $ mkStrictLam2 $ f v
355 | 
356 | -- | Force (evaluate) thunk and then project out the Haskell value.
357 | proj' :: HasValue a => Thunk -> EvalM a
358 | proj' = force >=> proj
359 | 
360 | numOp :: Pos -> (forall a. Num a => a -> a -> a) -> Value -> Value -> EvalM Value
361 | numOp _ op (VInt x) (VInt y) = return $ VInt $ x `op` y
362 | numOp _ op (VDbl x) (VDbl y) = return $ VDbl $ x `op` y
363 | numOp p _  v1       v2       = failOnValues p [v1, v2]
364 | 
365 | -- NB: evaluates deeply
366 | equalValues :: Pos -> Value -> Value -> EvalM Bool
367 | equalValues _ (VInt i1)  (VInt i2)  = return $ i1 == i2
368 | equalValues _ (VDbl d1)  (VDbl d2)  = return $ d1 == d2
369 | equalValues _ (VBool b1) (VBool b2) = return $ b1 == b2
370 | equalValues _ (VChar c1) (VChar c2) = return $ c1 == c2
371 | equalValues _ (VText s1) (VText s2) = return $ s1 == s2
372 | equalValues p (VList xs) (VList ys)
373 |     | length xs == length ys = and <$> zipWithM (equalValues p) xs ys
374 |     | otherwise = return False
375 | equalValues p (VRecord m1) (VRecord m2) = do
376 |     (ls1, vs1) <- unzip . recordValues <$> mapM force m1
377 |     (ls2, vs2) <- unzip . recordValues <$> mapM force m2
378 |     if length ls1 == length ls2 && length vs1 == length vs2
379 |        then and <$> zipWithM (equalValues p) vs1 vs2
380 |        else return False
381 | equalValues p (VVariant l1 v1) (VVariant l2 v2)
382 |     | l1 == l2  = join $ equalValues p <$> force v1 <*> force v2
383 |     | otherwise = return False
384 | equalValues p v1 v2 = failOnValues p [v1, v2]
385 | 
386 | -- NB: evaluates deeply
387 | compareValues :: Pos -> Value -> Value -> EvalM Ordering
388 | compareValues _ (VInt i1)  (VInt i2)  = return $ compare i1 i2
389 | compareValues _ (VDbl d1)  (VDbl d2)  = return $ compare d1 d2
390 | compareValues _ (VBool b1) (VBool b2) = return $ compare b1 b2
391 | compareValues _ (VChar c1) (VChar c2) = return $ compare c1 c2
392 | compareValues _ (VText s1) (VText s2) = return $ compare s1 s2
393 | compareValues p (VList xs) (VList ys) = go xs ys
394 |   where
395 |     go :: [Value] -> [Value] -> EvalM Ordering
396 |     go []      []      = return EQ
397 |     go (_:_)   []      = return GT
398 |     go []      (_:_)   = return LT
399 |     go (x:xs') (y:ys') = do
400 |           c <- compareValues p x y
401 |           if c == EQ
402 |               then go xs' ys'
403 |               else return c
404 | compareValues p v1 v2 = failOnValues p [v1, v2]
405 | 
406 | -- | Used for equality of records, sorts values by key
407 | recordValues :: HashMap Label a -> [(Label, a)]
408 | recordValues = List.sortBy (comparing fst) . HashMap.toList
409 | 
410 | packChars :: Pos -> Value -> EvalM Value
411 | packChars pos (VList xs)
412 |     | Just cs <- mapM extractChar xs = return . VText . T.pack $ cs
413 |     | otherwise = failOnValues pos xs
414 | packChars pos v = failOnValues pos [v]
415 | 
416 | unpackChars :: Pos -> Value -> EvalM Value
417 | unpackChars _   (VText s) = return . VList . map VChar . T.unpack $ s
418 | unpackChars pos v = failOnValues pos [v]
419 | 
420 | ------------------------------------------------------------
421 | -- HasValue class and instances
422 | 
423 | instance (HasValue a, HasValue b) => HasValue (a -> EvalM b) where
424 |     proj (VLam f) = return $ \x -> do
425 |       r <- f (Thunk $ return $ inj x)
426 |       proj r
427 |     proj v        = typeMismatch "VLam" v
428 |     inj f         = VLam $ \v -> proj' v >>= fmap inj . f
429 | 
430 | -- | A class of Haskell types that can be projected from or injected
431 | -- into Expresso values.
432 | class HasValue a where
433 |     proj :: Value -> EvalM a
434 |     inj  :: a -> Value
435 | 
436 | instance HasValue Value where
437 |     proj v        = return v
438 |     inj           = id
439 | 
440 | instance HasValue Integer where
441 |     proj (VInt i) = return i
442 |     proj v        = typeMismatch "VInt" v
443 |     inj           = VInt
444 | 
445 | instance HasValue Double where
446 |     proj (VDbl d) = return d
447 |     proj v        = typeMismatch "VDbl" v
448 |     inj           = VDbl
449 | 
450 | instance HasValue Bool where
451 |     proj (VBool b) = return b
452 |     proj v         = typeMismatch "VBool" v
453 |     inj            = VBool
454 | 
455 | instance HasValue Char where
456 |     proj (VChar c) = return c
457 |     proj v         = typeMismatch "VChar" v
458 |     inj            = VChar
459 | 
460 | instance HasValue String where
461 |     proj (VText s) = return $ T.unpack s
462 |     proj v         = typeMismatch "VText" v
463 |     inj            = VText . T.pack
464 | 
465 | instance HasValue Text where
466 |     proj (VText s) = return s
467 |     proj v         = typeMismatch "VText" v
468 |     inj            = VText
469 | 
470 | instance HasValue a => HasValue (Maybe a) where
471 |     proj = choice [ ("Just", fmap Just . proj)
472 |                   , ("Nothing", const $ pure Nothing)
473 |                   ]
474 |     inj  (Just x) = mkVariant "Just" (inj x)
475 |     inj  Nothing  = mkVariant "Nothing" unit
476 | 
477 | instance {-# OVERLAPS #-} HasValue a => HasValue [a] where
478 |     proj (VList xs) = mapM proj xs
479 |     proj v          = typeMismatch "VList" v
480 |     inj             = VList . map inj
481 | 
482 | instance {-# OVERLAPS #-} HasValue [Value] where
483 |     proj (VList xs)  = return xs
484 |     proj v           = typeMismatch "VList" v
485 |     inj              = VList
486 | 
487 | instance HasValue a => HasValue (HashMap Name a) where
488 |     proj (VRecord m) = mapM proj' m
489 |     proj v           = typeMismatch "VRecord" v
490 |     inj              = VRecord . fmap (Thunk . return . inj)
491 | 
492 | instance {-# OVERLAPS #-} HasValue a => HasValue [(Name, a)] where
493 |     proj v           = HashMap.toList <$> proj v
494 |     inj              = inj . HashMap.fromList
495 | 
496 | instance {-# OVERLAPS #-} HasValue (HashMap Name Thunk) where
497 |     proj (VRecord m) = return m
498 |     proj v           = typeMismatch "VRecord" v
499 |     inj              = VRecord
500 | 
501 | instance {-# OVERLAPS #-} HasValue [(Name, Thunk)] where
502 |     proj v           = HashMap.toList <$> proj v
503 |     inj              = inj . HashMap.fromList
504 | 
505 | instance {-# OVERLAPS #-} (HasValue a, HasValue b) => HasValue (a -> b) where
506 |     proj _ = throwError "proj not supported for pure functions"
507 |     inj f  = mkStrictLam $ fmap (inj . f) . proj
508 | 
509 | instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c) => HasValue (a -> b -> c) where
510 |     proj _ = throwError "proj not supported for pure functions"
511 |     inj f  = inj $ \x -> inj (f x)
512 | 
513 | instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c, HasValue d) => HasValue (a -> b -> c -> d) where
514 |     proj _ = throwError "proj not supported for pure functions"
515 |     inj f  = inj $ \x -> inj (f x)
516 | 
517 | instance {-# OVERLAPS #-} (HasValue a, HasValue b) => HasValue (a -> IO b) where
518 |     proj (VLam f) = return $ \x -> runEvalM' $ f (Thunk . return . inj $ x) >>= proj
519 |     proj v        = typeMismatch "VLam" v
520 |     inj f         = mkStrictLam $ \v -> proj v >>= \x -> inj <$> liftIO (f x)
521 | 
522 | instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c) => HasValue (a -> b -> IO c) where
523 |     proj v = proj v >>= \f -> return $ \x -> f x
524 |     inj f  = inj $ \x -> inj (f x)
525 | 
526 | instance {-# OVERLAPS #-} (HasValue a, HasValue b, HasValue c, HasValue d) => HasValue (a -> b -> c -> IO d) where
527 |     proj v = proj v >>= \f -> return $ \x -> f x
528 |     inj f  = inj $ \x -> inj (f x)
529 | 
530 | -- | Throw a type mismatch error.
531 | typeMismatch :: String -> Value -> EvalM a
532 | typeMismatch expected v = throwError $ "Type mismatch: expected a " ++ expected ++
533 |     ", but got: " ++ show (ppValue v)
534 | 
535 | -- | Project out a record field, fail with a type mismatch if it is not present.
536 | (.:) :: HasValue a => Value -> Name -> EvalM a
537 | (.:) (VRecord m) k = case HashMap.lookup k m of
538 |     Nothing -> throwError $ "Record label " ++ show k ++ " not present"
539 |     Just v  -> proj' v
540 | (.:) v _ = typeMismatch "VRecord" v
541 | 
542 | -- | Pair up a field name and a value. Intended to be used with @mkRecord@ or @mkVariant@.
543 | (.=) :: Name -> Value -> (Name, Thunk)
544 | (.=) k v = (k, Thunk . return $ v)
545 | 
546 | -- | Convenience for implementing @proj@ for a sum type.
547 | choice :: HasValue a => [(Name, Value -> EvalM a)] -> Value -> EvalM a
548 | choice alts = \case
549 |     VVariant k v
550 |         | Just f <- HashMap.lookup k m -> force v >>= f
551 |         | otherwise -> throwError $ "Missing label in alternatives: " ++ show k
552 |     v -> typeMismatch "VVariant" v
553 |   where
554 |     m = HashMap.fromList alts
555 | 
556 | -- | Convenience constructor for a record value.
557 | mkRecord :: [(Name, Thunk)] -> Value
558 | mkRecord = VRecord . HashMap.fromList
559 | 
560 | -- | Convenience constructor for a variant value.
561 | mkVariant :: Name -> Value -> Value
562 | mkVariant name = VVariant name . Thunk . return
563 | 
564 | -- | Unit value. Equivalent to @()@ in Haskell.
565 | unit :: Value
566 | unit = VRecord mempty
567 | 


--------------------------------------------------------------------------------
/src/Expresso/Parser.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts #-}
  2 | {-# LANGUAGE OverloadedStrings #-}
  3 | {-# LANGUAGE TupleSections #-}
  4 | {-# LANGUAGE ViewPatterns #-}
  5 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
  6 | 
  7 | -- |
  8 | -- Module      : Expresso.Parser
  9 | -- Copyright   : (c) Tim Williams 2017-2019
 10 | -- License     : BSD3
 11 | --
 12 | -- Maintainer  : info@timphilipwilliams.com
 13 | -- Stability   : experimental
 14 | -- Portability : portable
 15 | --
 16 | -- Parsers for Expresso terms and types.
 17 | --
 18 | module Expresso.Parser where
 19 | 
 20 | import Control.Applicative
 21 | import qualified Control.Exception as Ex
 22 | import Control.Monad
 23 | import Control.Monad.Except
 24 | import Control.Monad.Writer
 25 | import Data.Bifunctor
 26 | import Data.Maybe
 27 | import Text.Parsec hiding (many, optional, parse, (<|>))
 28 | import Text.Parsec.Language (emptyDef)
 29 | import qualified Data.Map as M
 30 | import qualified Data.Set as S
 31 | import qualified Data.Text as T
 32 | import qualified Text.Parsec as P
 33 | import qualified Text.Parsec.Expr as P
 34 | import qualified Text.Parsec.Token as P
 35 | 
 36 | import System.FilePath
 37 | import System.Directory
 38 | 
 39 | import Expresso.Pretty ( Doc, (<+>), render, parensList
 40 |                        , text, dquotes, vcat)
 41 | import Expresso.Syntax
 42 | import Expresso.Type
 43 | import Expresso.Utils
 44 | 
 45 | ------------------------------------------------------------
 46 | -- Resolve imports
 47 | 
 48 | resolveImports
 49 |     :: [FilePath]
 50 |     -> ExpI
 51 |     -- NB: ExceptT models expected failures, e.g. file not found
 52 |     -> ExceptT String IO (Exp, [SynonymDecl])
 53 | resolveImports libDirs = runWriterT . go
 54 |   where
 55 |     go :: ExpI -> WriterT [SynonymDecl] (ExceptT String IO) Exp
 56 |     go = cataM alg
 57 |       where
 58 |         alg (InR (K (Import path)) :*: _) = do
 59 |             (syns, e) <- lift $ do
 60 |                 str <- importFile path
 61 |                 ExceptT . return $ parse path str
 62 |             tell syns
 63 |             go e
 64 |         alg (InL e :*: pos) = return $ Fix (e :*: pos)
 65 | 
 66 |     -- importFile searches the provided library dirs, unless
 67 |     -- an absolute path is provided.
 68 |     importFile :: FilePath -> ExceptT String IO String
 69 |     importFile path
 70 |         | isAbsolute path = readFile' path
 71 |         | otherwise = do
 72 |               mfp <- lift $ findFirst libDirs
 73 |               case mfp of
 74 |                   Just fp -> readFile' fp
 75 |                   Nothing -> throwError $ unwords $
 76 |                       [ "Could not find imported file"
 77 |                       , "'" ++ path ++ "'"
 78 |                       , "in the following library directories:"
 79 |                       , show libDirs
 80 |                       ]
 81 |       where
 82 |         findFirst :: [FilePath] -> IO (Maybe FilePath)
 83 |         findFirst [] = return Nothing
 84 |         findFirst (dir:dirs) = do
 85 |             let fp = dir </> path
 86 |             exists <- doesFileExist fp
 87 |             if exists
 88 |                 then return (Just fp)
 89 |                 else findFirst dirs
 90 | 
 91 |         readFile' :: FilePath -> ExceptT String IO String
 92 |         readFile' fp =
 93 |             ExceptT $ bimap (show :: Ex.SomeException -> String) id
 94 |                   <$> Ex.try (readFile fp)
 95 | 
 96 | ------------------------------------------------------------
 97 | -- Parser
 98 | 
 99 | parse
100 |     :: SourceName
101 |     -> String
102 |     -> Either String ([SynonymDecl], ExpI)
103 | parse src = showError . P.parse (topLevel pTopLevel) src
104 | 
105 | topLevel p = whiteSpace *> p <* P.eof
106 | 
107 | pTopLevel = (,) <$> many (pSynonymDecl <* semi) <*> pExp
108 | 
109 | pSynonymDecl = SynonymDecl
110 |        <$> getPosition
111 |        <*> (reserved "type" *> upperIdentifier)
112 |        <*> many pTyVar
113 |        <*> (reservedOp "=" *> pType)
114 | 
115 | pExp     = addTypeAnnot
116 |        <$> getPosition
117 |        <*> pExp'
118 |        <*> optional (reservedOp ":" *> pTypeAnn)
119 | 
120 | addTypeAnnot pos e (Just t) = withPos pos (EAnn e t)
121 | addTypeAnnot _   e Nothing  = e
122 | 
123 | pExp'    = pImport
124 |        <|> pLam
125 |        <|> pAnnLam
126 |        <|> pLet
127 |        <|> pCond
128 |        <|> pCase
129 |        <|> pOpExp
130 |        <?> "expression"
131 | 
132 | pImport  = mkImport
133 |        <$> getPosition
134 |        <*> (reserved "import" *> stringLiteral)
135 |        <?> "import"
136 | 
137 | pLet     = reserved "let" *>
138 |            (flip (foldr mkLet) <$> (semiSep1 ((,) <$> getPosition <*> pLetDecl))
139 |                                <*> (reserved "in" *> pExp))
140 |            <?> "let expression"
141 | 
142 | pLetDecl = (,,) <$> pLetBind
143 |                 <*> optionMaybe (reservedOp ":" *> pTypeAnn)
144 |                 <*> (reservedOp "=" *> pExp <* whiteSpace)
145 | 
146 | pLam     = mkLam
147 |        <$> getPosition
148 |        <*> try (many1 pBind <* reservedOp "->" <* whiteSpace)
149 |        <*> pExp'
150 |        <?> "lambda expression"
151 | 
152 | pAnnLam  = mkAnnLam
153 |        <$> getPosition
154 |        <*> try (many1 (parens pAnnBind) <* reservedOp "->" <* whiteSpace)
155 |        <*> pExp'
156 |        <?> "lambda expression with type annotated argument"
157 | 
158 | pAnnBind = (,) <$> pBind <*> (reservedOp ":" *> pTypeAnn)
159 | 
160 | pAtom    = pPrim <|> try pVar <|> parens (pSection <|> pExp)
161 | 
162 | pSection = pSigSection
163 | 
164 | pSigSection = mkSigSection <$> getPosition <*> (reservedOp ":" *> pTypeAnn)
165 | 
166 | pVar     = mkVar <$> getPosition <*> lowerIdentifier
167 | 
168 | pPrim    = pNumber           <|>
169 |            pBool             <|>
170 |            pChar             <|>
171 |            pDifferenceRecord <|>
172 |            pRecord           <|>
173 |            pVariant          <|>
174 |            pVariantEmbed     <|>
175 |            pList             <|>
176 |            pString           <|>
177 |            pPrimFun
178 | 
179 | pCond    = (\pos -> mkTertiaryOp pos Cond)
180 |                <$> getPosition
181 |                <*> (reserved "if"   *> pExp)
182 |                <*> (reserved "then" *> pExp)
183 |                <*> (reserved "else" *> pExp)
184 |                <?> "if expression"
185 | 
186 | pOpExp   = P.buildExpressionParser opTable pApp
187 | 
188 | -- NB: assumes "-1" and "+1" are not valid terms
189 | pApp     = mkApp <$> getPosition <*> pTerm <*> many pTerm
190 | 
191 | pTerm    = mkRecordRestrict
192 |         <$> getPosition
193 |         <*> ((\pos -> foldl (mkRecordSelect pos))
194 |             <$> getPosition
195 |             <*> pAtom
196 |             <*> try (many pSelect))
197 |         <*> optional (reservedOp "\\" *> identifier)
198 | 
199 | opTable  = [ [ prefix "-" Neg
200 |              ]
201 |            , [ binary ">>" FwdComp        P.AssocRight
202 |              , binary "<<" BwdComp        P.AssocRight
203 |              ]
204 |            , [ binary "*" (ArithPrim Mul) P.AssocLeft
205 |              , binary "/" (ArithPrim Div) P.AssocLeft
206 |              ]
207 |            , [ binary "+" (ArithPrim Add) P.AssocLeft
208 |              , binary "-" (ArithPrim Sub) P.AssocLeft
209 |              ]
210 |            , [ binary "++" ListAppend     P.AssocLeft
211 |              , binary "::" ListCons       P.AssocRight
212 |              , binary "<>" TextAppend     P.AssocLeft
213 |              ]
214 |            , [ binary "==" Eq             P.AssocLeft
215 |              , binary "/=" NEq            P.AssocLeft
216 |              , binary ">"  (RelPrim RGT)  P.AssocLeft
217 |              , binary ">=" (RelPrim RGTE) P.AssocLeft
218 |              , binary "<"  (RelPrim RLT)  P.AssocLeft
219 |              , binary "<=" (RelPrim RLTE) P.AssocLeft
220 |              ]
221 |            , [ binary "&&" And            P.AssocRight
222 |              ]
223 |            , [ binary "||" Or             P.AssocRight
224 |              ]
225 |            ]
226 | 
227 | pPrimFun = msum
228 |   [ fun "error"   ErrorPrim
229 |   , fun "show"    Show
230 |   , fun "not"     Not
231 |   , fun "uncons"  ListUncons
232 |   , fun "fix"     FixPrim
233 |   , fun "double"  Double
234 |   , fun "floor"   Floor
235 |   , fun "ceiling" Ceiling
236 |   , fun "abs"     Abs
237 |   , fun "mod"     Mod
238 |   , fun "absurd"  Absurd
239 |   , fun "pack"    Pack
240 |   , fun "unpack"  Unpack
241 |   ]
242 |   where
243 |     fun sym prim = reserved sym *> ((\pos -> mkPrim pos prim) <$> getPosition)
244 | 
245 | binary sym prim =
246 |     P.Infix $ reservedOp sym *> ((\pos -> mkBinOp pos prim) <$> getPosition)
247 | prefix sym prim =
248 |     P.Prefix $ reservedOp sym *> ((\pos -> mkUnaryOp pos prim) <$> getPosition)
249 | 
250 | pSelect = reservedOp "." *> identifier
251 | 
252 | pNumber = (\pos -> either (mkInteger pos) (mkDouble pos))
253 |        <$> getPosition
254 |        <*> naturalOrFloat
255 | 
256 | pBool = (\pos -> mkPrim pos . Bool)
257 |      <$> getPosition
258 |      <*> (reserved "True"  *> pure True <|>
259 |           reserved "False" *> pure False)
260 | 
261 | pChar = (\pos -> mkPrim pos . Char)
262 |      <$> getPosition
263 |      <*> charLiteral
264 | 
265 | pString = (\pos -> mkPrim pos . Text . T.pack)
266 |        <$> getPosition
267 |        <*> stringLiteral
268 | 
269 | pBind = Arg <$> lowerIdentifier
270 |     <|> RecArg <$> pFieldBind
271 | 
272 | pLetBind = try (RecWildcard <$ reservedOp "{..}") <|> pBind
273 | 
274 | pFieldBind = braces $ pFieldBind' `sepBy` comma
275 |   where
276 |     pFieldBind'
277 |          = mkFieldBind
278 |         <$> pRecordLabel
279 |         <*> optionMaybe (reservedOp "=" *> lowerIdentifier)
280 | 
281 | data Entry = Extend Label ExpI | Update Label ExpI
282 | 
283 | pRecord = (\pos -> fromMaybe (mkRecordEmpty pos))
284 |        <$> getPosition
285 |        <*> (braces $ optionMaybe pRecordBody)
286 | 
287 | pRecordBody = mkRecordExtend <$> getPosition <*> pRecordEntry <*> pRest
288 |   where
289 |     pRest = (comma          *> pRecordBody)  <|>
290 |             (reservedOp "|" *> pExp)         <|>
291 |             (mkRecordEmpty <$> getPosition)
292 | 
293 | pDifferenceRecord = mkDifferenceRecord
294 |     <$> getPosition
295 |     <*> (try (reservedOp "{|") *> (pRecordEntry `sepBy1` comma)
296 |            <* reservedOp "|}")
297 | 
298 | mkDifferenceRecord :: Pos -> [Entry] -> ExpI
299 | mkDifferenceRecord pos entries =
300 |     withPos pos $ ELam (Arg "#r") $
301 |         foldr (mkRecordExtend pos) (withPos pos $ EVar "#r") entries
302 | 
303 | pRecordEntry =
304 |     try (Extend <$> pRecordLabel <*> (reservedOp "=" *> pExp))  <|>
305 |     try (Update <$> pRecordLabel <*> (reservedOp ":=" *> pExp)) <|>
306 |     mkFieldPun <$> getPosition <*> pRecordLabel
307 | 
308 | pRecordLabel  = lowerIdentifier
309 | 
310 | pVariant = mkVariant <$> getPosition <*> pVariantLabel
311 | 
312 | pVariantEmbed = mkVariantEmbed
313 |              <$> getPosition
314 |              <*> (try (reservedOp "<|") *> (pEmbedEntry `sepBy1` comma)
315 |                     <* reservedOp "|>")
316 |              <?> "variant embed expression"
317 |     where
318 |       pEmbedEntry = (,) <$> getPosition <*> pVariantLabel
319 | 
320 | pCase = mkCase <$> getPosition
321 |                <*> (reserved "case" *> pApp <* reserved "of")
322 |                <*> (braces pCaseBody)
323 |                <?> "case expression"
324 | 
325 | pCaseBody = mkCaseAlt <$> getPosition <*> pCaseAlt <*> pRest
326 |   where
327 |     pRest = (comma          *> pCaseBody)   <|>
328 |             (reservedOp "|" *> pExp)        <|>
329 |             (\pos -> mkPrim pos Absurd) <$> getPosition
330 | 
331 | pCaseAlt =
332 |     (try (Extend <$> pVariantLabel
333 |                  <*> (whiteSpace *> pLam)) <|>
334 |      try (Update <$> (reserved "override" *> pVariantLabel)
335 |                  <*> (whiteSpace *> pLam)))
336 |     <?> "case alternative"
337 | 
338 | pVariantLabel = upperIdentifier
339 | 
340 | pList = brackets pListBody
341 |   where
342 |     pListBody = (\pos -> foldr mkListCons (mkListEmpty pos))
343 |         <$> getPosition
344 |         <*> ((,) <$> getPosition <*> pExp) `sepBy` comma
345 |         <?> "list expression"
346 | 
347 | mkFieldBind :: Name -> Maybe Name -> (Name, Name)
348 | mkFieldBind l (Just n) = (l, n)
349 | mkFieldBind l Nothing  = (l, l)
350 | 
351 | mkImport :: Pos -> FilePath -> ExpI
352 | mkImport pos path = withAnn pos $ InR $ K $ Import path
353 | 
354 | mkInteger :: Pos -> Integer -> ExpI
355 | mkInteger pos = mkPrim pos . Int
356 | 
357 | mkDouble :: Pos -> Double -> ExpI
358 | mkDouble pos = mkPrim pos . Dbl
359 | 
360 | mkCase :: Pos -> ExpI -> ExpI -> ExpI
361 | mkCase pos scrutinee caseF = mkApp pos caseF [scrutinee]
362 | 
363 | mkCaseAlt :: Pos -> Entry -> ExpI -> ExpI
364 | mkCaseAlt pos (Extend l altLamE) contE =
365 |     mkApp pos (mkPrim pos $ VariantElim l) [altLamE, contE]
366 | mkCaseAlt pos (Update l altLamE) contE =
367 |     mkApp pos (mkPrim pos $ VariantElim l)
368 |           [ altLamE
369 |           , mkLam pos [Arg "#r"]
370 |                       (mkApp pos contE [mkEmbed $ withPos pos $ EVar "#r"])
371 |           ]
372 |   where
373 |     mkEmbed e = mkApp pos (mkPrim pos $ VariantEmbed l) [e]
374 | 
375 | mkVariant :: Pos -> Label -> ExpI
376 | mkVariant pos l = mkPrim pos $ VariantInject l
377 | 
378 | mkVariantEmbed :: Pos -> [(Pos , Label)] -> ExpI
379 | mkVariantEmbed pos ls =
380 |     withPos pos $ ELam (Arg "#r") $
381 |         foldr f (withPos pos $ EVar "#r") ls
382 |   where
383 |     f (pos, l) k = mkApp pos (mkPrim pos $ VariantEmbed l) [k]
384 | 
385 | mkLam :: Pos -> [Bind Name] -> ExpI -> ExpI
386 | mkLam pos bs e =
387 |     foldr (\b e -> withPos pos (ELam b e)) e bs
388 | 
389 | mkAnnLam :: Pos -> [(Bind Name, Type)] -> ExpI -> ExpI
390 | mkAnnLam pos bs e =
391 |     foldr (\(b, t) e -> withPos pos (EAnnLam b t e)) e bs
392 | 
393 | -- | signature section
394 | --   (:T) becomes (x -> x : T -> T)
395 | mkSigSection :: Pos -> Type -> ExpI
396 | mkSigSection pos ty =
397 |     withPos pos $ EAnn (mkLam pos [Arg "x"] (mkVar pos "x")) ty'
398 |   where
399 |     ty' = case ty of
400 |         (Fix (TForAllF tvs t :*: K pos)) ->
401 |             withAnn pos (TForAllF tvs (withAnn pos (TFunF t t)))
402 |         t -> withAnn (getAnn t) (TFunF t t)
403 | 
404 | mkVar :: Pos -> Name -> ExpI
405 | mkVar pos name = withPos pos (EVar name)
406 | 
407 | mkLet :: (Pos, (Bind Name, Maybe Type, ExpI)) -> ExpI -> ExpI
408 | mkLet (pos, (b, mty, e1)) e2 = withPos pos $
409 |     case mty of
410 |         Nothing -> ELet b e1 e2
411 |         Just t  -> EAnnLet b t e1 e2
412 | 
413 | mkTertiaryOp :: Pos -> Prim -> ExpI -> ExpI -> ExpI -> ExpI
414 | mkTertiaryOp pos p x y z = mkApp pos (mkPrim pos p) [x, y, z]
415 | 
416 | mkBinOp :: Pos -> Prim -> ExpI -> ExpI -> ExpI
417 | mkBinOp pos p x y = mkApp pos (mkPrim pos p) [x, y]
418 | 
419 | mkUnaryOp  :: Pos -> Prim -> ExpI -> ExpI
420 | mkUnaryOp pos p x = mkApp pos (mkPrim pos p) [x]
421 | 
422 | mkRecordSelect :: Pos -> ExpI -> Label -> ExpI
423 | mkRecordSelect pos r l = mkApp pos (mkPrim pos $ RecordSelect l) [r]
424 | 
425 | mkRecordExtend :: Pos -> Entry -> ExpI -> ExpI
426 | mkRecordExtend pos (Extend l e) r =
427 |     mkApp pos (mkPrim pos $ RecordExtend l) [e, r]
428 | mkRecordExtend pos (Update l e) r =
429 |     mkApp pos (mkPrim pos $ RecordExtend l) [e, mkRecordRestrict pos r $ Just l]
430 | 
431 | mkRecordEmpty :: Pos -> ExpI
432 | mkRecordEmpty pos = mkPrim pos RecordEmpty
433 | 
434 | mkRecordRestrict :: Pos -> ExpI -> Maybe Label -> ExpI
435 | mkRecordRestrict pos e = maybe e $ \l -> mkApp pos (mkPrim pos $ RecordRestrict l) [e]
436 | 
437 | mkFieldPun :: Pos -> Label -> Entry
438 | mkFieldPun pos l = Extend l (withPos pos $ EVar l)
439 | 
440 | mkListCons :: (Pos, ExpI) -> ExpI -> ExpI
441 | mkListCons (pos, x) xs = mkApp pos (mkPrim pos ListCons) [x, xs]
442 | 
443 | mkListEmpty :: Pos -> ExpI
444 | mkListEmpty pos = mkPrim pos ListEmpty
445 | 
446 | mkApp :: Pos -> ExpI -> [ExpI] -> ExpI
447 | mkApp pos f = foldl (\g -> withPos pos . EApp g) f
448 | 
449 | mkPrim :: Pos -> Prim -> ExpI
450 | mkPrim pos p = withPos pos $ EPrim p
451 | 
452 | withPos :: Pos -> ExpF Name Bind Type ExpI -> ExpI
453 | withPos pos = withAnn pos . InL
454 | 
455 | ------------------------------------------------------------
456 | -- Parsers for type annotations
457 | 
458 | pTypeAnn = pType'e >>= either (fail . render) return
459 |   where
460 |     pType'e = unboundTyVarCheck <$> getPosition <*> pType
461 | 
462 | pType = pTForAll
463 |     <|> pTFun
464 |     <|> pType'
465 | 
466 | pType' = pTVar
467 |      <|> pTInt
468 |      <|> pTDbl
469 |      <|> pTBool
470 |      <|> pTChar
471 |      <|> pTText
472 |      <|> pTSynonym
473 |      <|> pTRecord
474 |      <|> pTVariant
475 |      <|> pTList
476 |      <|> parens pType
477 | 
478 | pTForAll = pTForAll'e >>= either (fail . render) return
479 |   where
480 |     pTForAll'e = mkTForAll
481 |         <$> getPosition
482 |         <*> (reserved "forall" *> many1 pTyVar <* dot)
483 |         <*> option [] (try pConstraints)
484 |         <*> pType
485 |         <?> "forall type annotation"
486 | 
487 | pConstraints = ((:[]) <$> pConstraint
488 |            <|> parens (pConstraint `sepBy1` comma))
489 |            <* reservedOp "=>"
490 | 
491 | pConstraint = pStarConstraint
492 |           <|> pRowConstraint
493 | 
494 | pStarConstraint = (\c n -> (n, c))
495 |               <$> (CStar <$> pStarHierarchy)
496 |               <*> lowerIdentifier
497 |   where
498 |     pStarHierarchy = reserved "Eq"  *> pure CEq
499 |                  <|> reserved "Ord" *> pure COrd
500 |                  <|> reserved "Num" *> pure CNum
501 | 
502 | pRowConstraint = (,)
503 |              <$> (lowerIdentifier <* reservedOp "\\")
504 |              <*> (lacks . (:[]) <$> identifier)
505 | 
506 | -- simple syntactic check for unbound type variables in type annotations
507 | unboundTyVarCheck :: Pos -> Type -> Either Doc Type
508 | unboundTyVarCheck pos t
509 |     | not (null freeVars) = Left $ vcat
510 |           [ ppPos pos <> ":"
511 |           , "unbound type variable(s)" <+> parensList (map ppTyVarName freeVars) <+> "in type annotation."
512 |           ]
513 |     | otherwise           = return t
514 |   where
515 |     freeVars    = S.toList $ S.delete "_" (S.map tyvarName $ ftv t)
516 |     ppTyVarName = dquotes . text
517 | 
518 | -- match up constraints and bound type variables
519 | mkTForAll :: Pos -> [TyVar] -> [(Name, Constraint)] -> Type -> Either Doc Type
520 | mkTForAll pos tvs (M.fromListWith unionConstraints -> m) t
521 |     | not (null badNames) = Left $ vcat
522 |           [ ppPos pos <> ":"
523 |           , "constraint(s) reference unknown type variable(s):" <+> parensList (map (dquotes . text) badNames)
524 |           ]
525 |     | otherwise = return $ withAnn pos (TForAllF tvs' t')
526 |   where
527 |     t' = substTyVar tvs (map (withAnn pos . TVarF) tvs') t
528 |     tvs' = [ maybe tv (setConstraint tv) $ M.lookup (tyvarName tv) m
529 |            | tv <- tvs
530 |            ]
531 |     setConstraint tv c = tv { tyvarConstraint = c }
532 |     bndrs     = S.fromList $ map tyvarName tvs
533 |     badNames  = S.toList $ M.keysSet m  S.\\ bndrs
534 | 
535 | pTVar = (\pos -> withAnn pos . TVarF)
536 |     <$> getPosition
537 |     <*> (pTyVar <|> pTWildcard)
538 | 
539 | pTSynonym = (\pos name -> withAnn pos . TSynonymF name)
540 |     <$> getPosition
541 |     <*> upperIdentifier
542 |     <*> many pType'
543 | 
544 | pTInt  = pTCon TIntF "Int"
545 | pTDbl  = pTCon TDblF "Double"
546 | pTBool = pTCon TBoolF "Bool"
547 | pTChar = pTCon TCharF "Char"
548 | pTText = pTCon TTextF "Text"
549 | 
550 | pTFun = (\pos a b -> withAnn pos (TFunF a b))
551 |      <$> getPosition
552 |      <*> try (pType' <* reservedOp "->" <* whiteSpace) -- TODO
553 |      <*> pType
554 |      <?> "function type annotation"
555 | 
556 | pTCon c s = (\pos -> withAnn pos c) <$> getPosition <* reserved s
557 | 
558 | pTyVar = mkTyVar Bound <$> lowerIdentifier
559 | pTWildcard = mkTyVar Wildcard "_" <$ reservedOp "_"
560 | 
561 | mkTyVar flavour name = TyVar flavour name (head name) CNone
562 | 
563 | pTRecord = mkFromRowType TRecordF
564 |        <$> getPosition
565 |        <*> (try (Just <$> braces pTVar) <|> (braces $ optionMaybe (pTRowBody pTRecordEntry)))
566 |        <?> "record type annotation"
567 | 
568 | pTVariant = mkFromRowType TVariantF
569 |        <$> getPosition
570 |        <*> (try (Just <$> angles pTVar) <|> (angles $ optionMaybe (pTRowBody pTVariantEntry)))
571 |        <?> "variant type annotation"
572 | 
573 | pTRowBody pEntry = mkTRowExtend
574 |                <$> getPosition
575 |                <*> pEntry
576 |                <*> pRest
577 |   where
578 |     pRest = (comma          *> pTRowBody pEntry)  <|>
579 |             (reservedOp "|" *> pType')            <|>
580 |             (mkTRowEmpty <$> getPosition)
581 | 
582 | mkFromRowType tCon pos =
583 |     withAnn pos . tCon . fromMaybe (mkTRowEmpty pos)
584 | 
585 | pTRecordEntry = (,) <$> pRecordLabel <*> (reservedOp ":" *> pType)
586 | pTVariantEntry = (,) <$> pVariantLabel <*> (reservedOp ":" *> pType)
587 | 
588 | mkTRowExtend pos (l, ty) r = withAnn pos $ TRowExtendF l ty r
589 | mkTRowEmpty pos = withAnn pos TRowEmptyF
590 | 
591 | pTList = (\pos -> withAnn pos . TListF)
592 |      <$> getPosition
593 |      <*> brackets pType
594 | 
595 | ------------------------------------------------------------
596 | -- Language definition for Lexer
597 | 
598 | languageDef :: P.LanguageDef st
599 | languageDef = emptyDef
600 |     { P.commentStart   = "{-"
601 |     , P.commentEnd     = "-}"
602 |     , P.commentLine    = "--"
603 |     , P.nestedComments = True
604 |     , P.identStart     = letter
605 |     , P.identLetter    = alphaNum <|> oneOf "_'"
606 |     , P.opStart        = P.opLetter languageDef
607 |     , P.opLetter       = oneOf ":!#$%&*+./<=>?@\\^|-~"
608 |     , P.reservedOpNames= [ "->", "=", "-", "*", "/", "+"
609 |                          , "++", "::", "|", ",", ".", "\\"
610 |                          , "{|", "|}", ":=", "{..}"
611 |                          , "==", "/=", ">", ">=", "<", "<="
612 |                          , "&&", "||", ":", "=>"
613 |                          ]
614 |     , P.reservedNames  = [ "let", "in", "if", "then", "else", "case", "of"
615 |                          , "True", "False", "forall", "Eq", "Ord", "Num"
616 |                          , "type"
617 |                          ]
618 |     , P.caseSensitive  = True
619 |     }
620 | 
621 | 
622 | ------------------------------------------------------------
623 | -- Lexer
624 | 
625 | lexer = P.makeTokenParser languageDef
626 | 
627 | lowerIdentifier = lookAhead lower >> identifier
628 | upperIdentifier = lookAhead upper >> identifier
629 | 
630 | identifier = P.identifier lexer
631 | reserved = P.reserved lexer
632 | operator = P.operator lexer
633 | reservedOp = P.reservedOp lexer
634 | charLiteral = P.charLiteral lexer
635 | stringLiteral = P.stringLiteral lexer
636 | --natural = P.natural lexer
637 | --integer = P.integer lexer
638 | --float = P.float lexer
639 | naturalOrFloat = P.naturalOrFloat lexer
640 | --decimal = P.decimal lexer
641 | --hexadecimal = P.hexadecimal lexer
642 | --octal = P.octal lexer
643 | symbol = P.symbol lexer
644 | lexeme = P.lexeme lexer
645 | whiteSpace = P.whiteSpace lexer
646 | parens = P.parens lexer
647 | braces = P.braces lexer
648 | angles = P.angles lexer
649 | brackets = P.brackets lexer
650 | semi = P.semi lexer
651 | comma = P.comma lexer
652 | colon = P.colon lexer
653 | dot = P.dot lexer
654 | semiSep = P.semiSep lexer
655 | semiSep1 = P.semiSep1 lexer
656 | commaSep = P.commaSep lexer
657 | commaSep1 = P.commaSep1 lexer
658 | 


--------------------------------------------------------------------------------
/src/Expresso/TypeCheck.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DeriveFunctor #-}
  2 | {-# LANGUAGE FlexibleContexts #-}
  3 | {-# LANGUAGE FlexibleInstances #-}
  4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  5 | {-# LANGUAGE OverloadedStrings #-}
  6 | {-# LANGUAGE PatternGuards #-}
  7 | {-# LANGUAGE TypeOperators #-}
  8 | {-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
  9 | 
 10 | -- |
 11 | -- Module      : Expresso.TypeCheck
 12 | -- Copyright   : (c) Tim Williams 2017-2019
 13 | -- License     : BSD3
 14 | --
 15 | -- Maintainer  : info@timphilipwilliams.com
 16 | -- Stability   : experimental
 17 | -- Portability : portable
 18 | --
 19 | -- Type inference and checking.
 20 | --
 21 | -- The type system implemented here is a bi-directional Damas-Milner system extended with
 22 | -- higher-rank polymorphism, type wildcards and polymorphic extensible (constrained) row types.
 23 | --
 24 | -- The algorithm is described in detail by the tutorial paper:
 25 | -- "Practical type inference for arbitrary-rank types" Peyton-Jones et al. 2011.
 26 | --
 27 | -- The row-types extension is based on ideas from the following papers:
 28 | -- * "A Polymorphic Type System for Extensible Records and Variants" B. R. Gaster and M. P. Jones, 1996.
 29 | -- * "Extensible records with scoped labels" D. Leijen, 2005.
 30 | --
 31 | module Expresso.TypeCheck (
 32 |       typeCheck
 33 |     , tcDecl
 34 |     , runTI
 35 |     , initTIState
 36 |     , TI
 37 |     , TIState
 38 |     ) where
 39 | 
 40 | import qualified Data.List as L
 41 | import qualified Data.Map as M
 42 | import qualified Data.Set as S
 43 | 
 44 | import Control.Applicative ((<$>))
 45 | import Control.Monad.Except
 46 | import Control.Monad.Reader
 47 | import Control.Monad.State
 48 | 
 49 | import Expresso.Syntax
 50 | import Expresso.Type
 51 | import Expresso.Pretty
 52 | import Expresso.Utils
 53 | 
 54 | -- | Internal state of the inference engine.
 55 | data TIState = TIState
 56 |     { tiSupply :: Int
 57 |     , tiSubst  :: Subst
 58 |     }
 59 | 
 60 | data TIEnv = TIEnv
 61 |     { tiTypeEnv  :: TypeEnv
 62 |     , tiSynonyms :: Synonyms
 63 |     }
 64 | 
 65 | type TI a = ExceptT String (ReaderT TIEnv (State TIState)) a
 66 | 
 67 | -- | Type check the supplied expression.
 68 | typeCheck :: Exp -> TI Sigma
 69 | typeCheck e = tcRho e Nothing >>= inferSigma (getAnn e)
 70 | 
 71 | -- | Run the type inference monad.
 72 | runTI
 73 |     :: TI a
 74 |     -> TypeEnv
 75 |     -> Synonyms
 76 |     -> TIState
 77 |     -> (Either String a, TIState)
 78 | runTI t tEnv syns =
 79 |     runState (runReaderT (runExceptT t) (TIEnv tEnv syns))
 80 | 
 81 | -- | Initial state of the inference engine.
 82 | initTIState :: TIState
 83 | initTIState = TIState { tiSupply = 0, tiSubst = mempty }
 84 | 
 85 | fresh :: TI Int
 86 | fresh = do
 87 |   s <- get
 88 |   let i = tiSupply s
 89 |   put s {tiSupply = i + 1 }
 90 |   return i
 91 | 
 92 | -- Used by tcPrim
 93 | newTyVar :: Constraint -> Char -> TyVar
 94 | newTyVar c prefix = TyVar Bound [prefix] prefix c
 95 | 
 96 | newSkolemTyVar :: TyVar -> TI TyVar
 97 | newSkolemTyVar (TyVar _ _ prefix c) = do
 98 |   i <- fresh
 99 |   let name = prefix : show i
100 |   return $ TyVar Skolem name prefix c
101 | 
102 | newMetaVar :: Pos -> Constraint -> Char -> TI Type
103 | newMetaVar pos c prefix =
104 |     annotate pos . TMetaVar <$> newMetaTyVar c prefix
105 | 
106 | newMetaTyVar :: Constraint -> Char -> TI MetaTv
107 | newMetaTyVar c prefix = do
108 |   i <- fresh
109 |   return $ MetaTv i prefix c
110 | 
111 | getEnvTypes :: TI [Sigma]
112 | getEnvTypes =
113 |     (M.elems . unTypeEnv <$> asks tiTypeEnv) >>= mapM substType
114 | 
115 | substType :: Type -> TI Type
116 | substType t = do
117 |   s <- gets tiSubst
118 |   return $ apply s t
119 | 
120 | lookupVar :: Pos -> Name -> TI Sigma
121 | lookupVar pos name = do
122 |     TypeEnv env <- asks tiTypeEnv
123 |     case M.lookup name env of
124 |         Just s  -> return s
125 |         Nothing -> throwError . show $
126 |             ppPos pos <+> ": unbound variable:" <+> text name
127 | 
128 | extendEnv :: M.Map Name Sigma -> TI a -> TI a
129 | extendEnv binds =
130 |     local $ \e -> e { tiTypeEnv = TypeEnv binds <> tiTypeEnv e }
131 | 
132 | -- | Quantify over the specified type variables (all flexible).
133 | quantify :: Pos -> [MetaTv] -> Rho -> Sigma
134 | quantify pos mvs0 t =
135 |     withAnn pos $ TForAllF tvs t'
136 |   where
137 |      -- group by prefix and number sequentially each prefix
138 |     (mvs, tvs) = unzip
139 |                . concat
140 |                . M.elems
141 |                . M.mapWithKey mkSubsts
142 |                . M.fromListWith (++)
143 |                . map (metaPrefix &&& (:[]))
144 |                $ mvs0
145 |     s  = mconcat $ zipWith (|->) mvs (map TVar tvs)
146 |     t' = apply s t
147 | 
148 |     -- avoid quantified type variables in use
149 |     usedBndrs = map tyvarName $ S.toList $ tyVarBndrs t
150 | 
151 |     mkSubsts p mvs =
152 |         zipWith mkSubst mvs (prefixBndrs L.\\ usedBndrs)
153 |       where
154 |         prefixBndrs = [p] : [ p : show i | i <- [(1::Integer)..]]
155 |         mkSubst mv name =
156 |             (mv, TyVar Bound name p (metaConstraint mv))
157 | 
158 | -- | Instantiate the topmost foralls of the argument type
159 | -- with flexible type variables.
160 | instantiate :: Pos -> Sigma -> TI Rho
161 | instantiate pos (TForAll tvs t) = do
162 |   tvs' <- mapM (\v -> newMetaTyVar (tyvarConstraint v) (tyvarPrefix v)) tvs
163 |   let ts = map (annotate pos . TMetaVar) tvs'
164 |   s <- gets tiSubst
165 |   return $ substTyVar tvs ts (apply s t)
166 | instantiate _ t = return t
167 | 
168 | -- | Performs deep skolemisation, returning the
169 | -- skolem constants and the skolemised type.
170 | skolemise :: Pos -> Sigma -> TI ([TyVar], Rho)
171 | skolemise pos (TForAll tvs t) = do
172 |     sks1  <- mapM newSkolemTyVar tvs
173 |     let sksTs = map (annotate pos . TVar) sks1
174 |     t <- substType t
175 |     (sks2, t') <- skolemise pos $ substTyVar tvs sksTs t
176 |     return (sks1 ++ sks2, t')
177 | skolemise pos (TFun argT resT) = do
178 |     (sks, resT') <- skolemise pos resT
179 |     return (sks, withAnn pos (TFunF argT resT'))
180 | skolemise _ t =
181 |     return ([], t)
182 | 
183 | unify :: Type -> Type -> TI ()
184 | unify t1 t2 = do
185 |   s <- gets tiSubst
186 |   u <- mgu (apply s t1) (apply s t2)
187 |   modify (\st -> st { tiSubst = u <> tiSubst st })
188 | 
189 | mgu :: Type -> Type -> TI Subst
190 | mgu (TFun l r) (TFun l' r') = do
191 |   s1 <- mgu l l'
192 |   s2 <- mgu (apply s1 r) (apply s1 r')
193 |   return $ s2 <> s1
194 | mgu (TMetaVar u) t@(TMetaVar v) = unifyConstraints (getAnn t) u v
195 | mgu l@(TMetaVar v) t = varBind (getAnn l) v t
196 | mgu t r@(TMetaVar v) = varBind (getAnn r) v t
197 | mgu (TVar u) (TVar v)
198 |     | u == v = return nullSubst
199 | mgu t1@(TSynonym n1 ts1) t2@(TSynonym n2 ts2) -- no need to expand
200 |     | n1 == n2  = mconcat <$> zipWithM mgu ts1 ts2
201 |     | otherwise = throwError'
202 |     [ "Type synonyms do not unify:"
203 |     , ppPos (getAnn t1) <+> ":" <+> ppType t1
204 |     , ppPos (getAnn t2) <+> ":" <+> ppType t2
205 |     ]
206 | mgu l@(TSynonym n1 ts1) t2 = do
207 |     t1 <- expandSynonym (getAnn l) n1 ts1
208 |     mgu t1 t2
209 | mgu t1 r@(TSynonym n2 ts2) = do
210 |     t2 <- expandSynonym (getAnn r) n2 ts2
211 |     mgu t1 t2
212 | mgu TInt TInt = return nullSubst
213 | mgu TDbl TDbl = return nullSubst
214 | mgu TBool TBool = return nullSubst
215 | mgu TChar TChar = return nullSubst
216 | mgu TText TText = return nullSubst
217 | mgu (TList u) (TList v) = mgu u v
218 | mgu (TRecord row1) (TRecord row2) = mgu row1 row2
219 | mgu (TVariant row1) (TVariant row2) = mgu row1 row2
220 | mgu TRowEmpty TRowEmpty = return nullSubst
221 | mgu row1@TRowExtend{} row2@TRowEmpty = unifyRow row1 row2
222 | mgu row1@TRowEmpty row2@TRowExtend{} = unifyRow row2 row1
223 | mgu row1@TRowExtend{} row2@TRowExtend{} = unifyRow row1 row2
224 | mgu t1 t2 = throwError'
225 |     [ "Types do not unify:"
226 |     , ppPos (getAnn t1) <+> ":" <+> ppType t1
227 |     , ppPos (getAnn t2) <+> ":" <+> ppType t2
228 |     ]
229 | 
230 | expandSynonym :: Pos -> Name -> [Type] -> TI Type
231 | expandSynonym pos name args = do
232 |     syns <- asks tiSynonyms
233 |     case lookupSynonym name args syns of
234 |         Just ty -> return ty
235 |         Nothing -> throwError'
236 |             [ "Could not expand type synonym:"
237 |             , ppPos pos <+> ":" <+> ppType (TSynonym name args)
238 |             ]
239 | 
240 | unifyRow :: Type -> Type -> TI Subst
241 | unifyRow row1@TRowExtend{} row2@TRowEmpty = throwError'
242 |     [ "Cannot unify the row at" <+> ppPos (getAnn row1)
243 |     , "with the row at" <+> ppPos (getAnn row2)
244 |     , "due to the row label(s)" <+> ppRowLabels row1
245 |     ]
246 | unifyRow row1@(TRowExtend label1 fieldTy1 rowTail1) row2@TRowExtend{} = do
247 |   -- apply side-condition to ensure termination
248 |   (fieldTy2, rowTail2, theta1) <- rewriteRow (getAnn row1) (getAnn row2) row2 label1
249 |   case snd (toList rowTail1) >>= extractMetaTv of
250 |     Just tv | isInSubst tv theta1 ->
251 |                   throwError $ show (getAnn row1) ++ " : recursive row type"
252 |     _ -> do
253 |       theta2 <- mgu (apply theta1 fieldTy1) (apply theta1 fieldTy2)
254 |       let s = theta2 <> theta1
255 |       theta3 <- mgu (apply s rowTail1) (apply s rowTail2)
256 |       return $ theta3 <> s
257 | unifyRow t1 t2 = error $ "Assertion failed: " ++ show (t1, t2)
258 | 
259 | -- | in order to unify two meta type variables, we must unify any constraints
260 | unifyConstraints :: Pos -> MetaTv -> MetaTv -> TI Subst
261 | unifyConstraints pos u v
262 |   | u == v    = return nullSubst
263 |   | otherwise =
264 |       case (metaConstraint u, metaConstraint v) of
265 |        (CNone, CNone) ->
266 |            return $ u |-> annotate pos (TMetaVar v)
267 |        (c1, c2) -> do
268 |            let prefix = metaPrefix v
269 |            w <- newMetaVar pos (c1 `unionConstraints` c2) prefix
270 |            return $ mconcat
271 |                [ u |-> w
272 |                , v |-> w
273 |                ]
274 | 
275 | varBind :: Pos -> MetaTv -> Type -> TI Subst
276 | varBind pos u t
277 |   | u `S.member` meta t = throwError'
278 |         [ "Occur check fails:"
279 |         , ppPos pos        <+> ppType (TMetaVar u)
280 |         , "occurs in"
281 |         , ppPos (getAnn t) <+> ppType t
282 |         ]
283 |   | otherwise          = do
284 |         syns <- asks tiSynonyms
285 |         case metaConstraint u of
286 |             CNone  -> return $ u |-> t
287 |             CStar c
288 |                 | satisfies syns t (metaConstraint u) ->
289 |                       return $ u |-> t
290 |                 | otherwise ->
291 |                       throwError'
292 |                           [ "The type:"
293 |                           , ppPos (getAnn t) <+> ":" <+> ppType t
294 |                           , "does not satisfy the constraint:"
295 |                           , ppPos pos <+> ":" <+> ppStarConstraint c
296 |                           ]
297 |             CRow{} -> varBindRow (getAnn t) u t
298 | 
299 | -- | bind the row tyvar to the row type, as long as the row type does not
300 | -- contain the labels in the tyvar lacks constraint; and propagate these
301 | -- label constraints to the row variable in the row tail, if there is one.
302 | varBindRow :: Pos -> MetaTv -> Type -> TI Subst
303 | varBindRow pos u t
304 |   = case S.toList (ls `S.intersection` ls') of
305 |       [] | Nothing <- mv -> return s1
306 |          | Just r1 <- mv -> do
307 |              let c = ls `S.union` labelsFrom r1
308 |              r2 <- newMetaVar pos (CRow c) 'r'
309 |              let s2 = r1 |-> r2
310 |              return $ s1 <> s2
311 |       labels             -> throwError . show $
312 |                                 ppPos pos <+> ": repeated label(s):"
313 |                                           <+> sepBy comma (map text labels)
314 |   where
315 |     ls           = labelsFrom u
316 |     (ls', mv)    = (S.fromList . map fst) *** (>>= extractMetaTv) $ toList t
317 |     s1           = u |-> t
318 |     labelsFrom v = case metaConstraint v of
319 |         CRow s -> s
320 |         _      -> S.empty
321 | 
322 | rewriteRow :: Pos -> Pos -> Type -> Label -> TI (Type, Type, Subst)
323 | rewriteRow pos1 pos2 (Fix (TRowEmptyF :*: _)) newLabel =
324 |   throwError . show $
325 |       ppPos pos1 <+> ": label"
326 |                  <+> text newLabel
327 |                  <+> "cannot be inserted into row type introduced at"
328 |                  <+> ppPos pos2
329 | rewriteRow pos1 pos2 (Fix (TRowExtendF label fieldTy rowTail :*: K pos)) newLabel
330 |   | newLabel == label     =
331 |       -- nothing to do
332 |       return (fieldTy, rowTail, nullSubst)
333 |   | TVar v <- rowTail, tyvarFlavour v == Skolem =
334 |       throwError . show $ vcat
335 |           [ ppPos pos1 <+> ": Type not polymorphic enough:"
336 |           , ppPos pos2
337 |           ]
338 |   | TMetaVar alpha <- rowTail = do
339 |       beta  <- newMetaVar pos (lacks [newLabel]) 'r'
340 |       gamma <- newMetaVar pos CNone 'a'
341 |       s      <- varBindRow pos alpha
342 |                     $ withAnn pos
343 |                     $ TRowExtendF newLabel gamma beta
344 |       return ( gamma
345 |              , apply s $ withAnn pos $ TRowExtendF label fieldTy beta
346 |              , s
347 |              )
348 |   | otherwise   = do
349 |       (fieldTy', rowTail', s) <- rewriteRow pos1 pos2 rowTail newLabel
350 |       return (fieldTy', TRowExtend label fieldTy rowTail', s)
351 | rewriteRow _ _ ty _ = error $ "Unexpected type: " ++ show ty
352 | 
353 | -- | type-checking and inference
354 | tcRho :: Exp -> Maybe Rho -> TI Type
355 | tcRho = cata alg
356 |   where
357 |     alg :: (ExpF Name Bind Type :*: K Pos) (Maybe Rho -> TI Type)
358 |         -> Maybe Rho
359 |         -> TI Type
360 |     alg (EVar n :*: K pos) mty = do
361 |         sigma <- lookupVar pos n
362 |         instSigma pos sigma mty
363 |     alg (EPrim prim :*: K pos) mty = do
364 |         let sigma = tcPrim pos prim
365 |         instSigma pos sigma mty
366 |     alg (ELam b e :*: K pos) Nothing = do
367 |         varT <- newMetaVar pos CNone 'a'
368 |         binds <- tcBinds pos b $ Just varT
369 |         extendEnv binds $ do
370 |             resT <- e Nothing
371 |             return $ withAnn pos $ TFunF varT resT
372 |     alg (ELam b e :*: K pos) (Just ty) = do
373 |         (varT, bodyT) <- unifyFun pos ty
374 |         binds <- tcBinds pos b $ Just varT
375 |         extendEnv binds $
376 |             e (Just bodyT)
377 |     alg (EAnnLam b argT e :*: K pos) Nothing = do
378 |         argT  <- instWildcards argT
379 |         binds <- tcBinds pos b $ Just argT
380 |         extendEnv binds $ do
381 |             resT <- e Nothing
382 |             return $ withAnn pos $ TFunF argT resT
383 |     alg (EAnnLam b varT e :*: K pos) (Just ty) = do
384 |         varT  <- instWildcards varT
385 |         (argT, bodyT) <- unifyFun pos ty
386 |         subsCheck pos argT varT
387 |         binds <- tcBinds pos b $ Just varT
388 |         extendEnv binds $
389 |             e (Just bodyT)
390 |     alg (EApp e1 e2 :*: K pos) mty = do
391 |         funT <- e1 Nothing
392 |         (argT, resT) <- unifyFun pos funT
393 |         checkSigma pos e2 argT
394 |         instSigma pos resT mty
395 |     alg (ELet b e1 e2 :*: K pos) mty = do
396 |         t1 <- e1 Nothing
397 |         binds <- tcBinds pos b (Just t1) >>= mapM (inferSigma pos)
398 |         extendEnv binds $
399 |             e2 mty
400 |     alg (EAnnLet b varT e1 e2 :*: K pos) mty = do
401 |         varT  <- instWildcards varT
402 |         t1 <- e1 Nothing
403 |         subsCheck pos t1 varT
404 |         binds <- tcBinds pos b $ Just varT
405 |         extendEnv binds $
406 |             e2 mty
407 |     alg (EAnn e annT :*: K pos) mty = do
408 |         annT  <- instWildcards annT
409 |         checkSigma pos e annT
410 |         instSigma pos annT mty
411 | 
412 | inferSigma :: Pos -> Rho -> TI Sigma
413 | inferSigma pos rho = do
414 |     exp_ty  <- substType rho
415 |     env_tys <- getEnvTypes
416 |     let env_tvs    = meta env_tys
417 |         res_tvs    = meta [exp_ty]
418 |         forall_tvs = S.toList $ res_tvs S.\\ env_tvs
419 |     return $ quantify pos forall_tvs exp_ty
420 | 
421 | checkSigma :: Pos -> (Maybe Rho -> TI Rho) -> Sigma -> TI ()
422 | checkSigma pos e sigma = do
423 |     (skol_tvs, rho) <- skolemise pos sigma
424 |     void $ e (Just rho)
425 |     env_tys <- getEnvTypes
426 |     let esc_tvs = ftv (sigma : env_tys)
427 |         bad_tvs = filter (`S.member` esc_tvs) skol_tvs
428 |     unless (null bad_tvs) $
429 |          throwError'
430 |               [ ppPos pos <+> ": Type not polymorphic enough:"
431 |               , parensList (map (text . tyvarName) bad_tvs)
432 |               ]
433 | 
434 | instSigma :: Pos -> Sigma -> Maybe Rho -> TI Type
435 | instSigma pos t1 Nothing   = instantiate pos t1
436 | instSigma pos t1 (Just t2) = subsCheckRho pos t1 t2 >> return t2
437 | 
438 | -- NOTE: Currently we support only simple unamed type wildcards.
439 | -- Each one is distinct and we generate fresh meta vars for them.
440 | instWildcards :: Rho -> TI Rho
441 | instWildcards = cataM alg
442 |   where
443 |     alg :: (TypeF :*: K Pos) Type -> TI Type
444 |     alg (TVarF v :*: K pos) | tyvarFlavour v == Wildcard = do
445 |           mv <- newMetaTyVar (tyvarConstraint v) 't'
446 |           return $ withAnn pos (TMetaVarF mv)
447 |     alg e = return $ Fix e
448 | 
449 | tcBinds :: Pos -> Bind Name -> Maybe Rho -> TI (M.Map Name Type)
450 | tcBinds pos arg           Nothing   =
451 |     newMetaVar pos CNone 'a' >>= tcBinds pos arg . Just
452 | tcBinds _   (Arg n)       (Just ty) =
453 |     return $ M.singleton n ty
454 | tcBinds pos (RecArg bs)   (Just ty) = do
455 |     let (ls, ns) = unzip bs
456 |     tvs <- mapM (const $ newMetaVar pos CNone 'l') ls
457 |     r   <- newMetaVar pos (lacks ls) 'r' -- implicit tail
458 |     unify ty (TRecord $ mkRowType r $ zip ls tvs)
459 |     return $ M.fromList $ zip ns tvs
460 | tcBinds pos RecWildcard   (Just ty) = do
461 |     s <- gets tiSubst
462 |     case apply s ty of
463 |         TRecord r -> return $ rowToMap r
464 |         _         ->
465 |             throwError . show $
466 |                 ppPos pos <+> ": record wildcard cannot bind to type:"
467 |                           <+> ppType ty
468 | 
469 | 
470 | subsCheck :: Pos -> Sigma -> Sigma -> TI ()
471 | subsCheck pos sigma1 sigma2 = do
472 |     (skol_tvs, rho2) <- skolemise pos sigma2
473 |     subsCheckRho pos sigma1 rho2
474 |     let esc_tvs = ftv [sigma1, sigma2]
475 |         bad_tvs = filter (`S.member` esc_tvs) skol_tvs
476 |     unless (null bad_tvs) $
477 |         throwError'
478 |             [ ppPos pos <+> ": Subsumption check failed:"
479 |             , indent 2 (ppType sigma1)
480 |             , text "is not as polymorphic as"
481 |             , indent 2 (ppType sigma2)
482 |             ]
483 | 
484 | subsCheckRho :: Pos -> Sigma -> Rho -> TI ()
485 | subsCheckRho pos sigma1@(TForAll _ _) rho2 = do
486 |     rho1 <- instantiate pos sigma1
487 |     subsCheckRho pos rho1 rho2
488 | subsCheckRho pos rho1 (TFun a2 r2) = do
489 |     (a1, r1) <- unifyFun pos rho1
490 |     subsCheckFun pos a1 r1 a2 r2
491 | subsCheckRho pos (TFun a1 r1) rho2 = do
492 |     (a2, r2) <- unifyFun pos rho2
493 |     subsCheckFun pos a1 r1 a2 r2
494 | subsCheckRho _   tau1 tau2 =
495 |     unify tau1 tau2
496 | 
497 | subsCheckFun :: Pos -> Sigma -> Rho -> Sigma -> Rho -> TI ()
498 | subsCheckFun pos a1 r1 a2 r2 = do
499 |     subsCheck pos a2 a1
500 |     subsCheckRho pos r1 r2
501 | 
502 | unifyFun :: Pos -> Rho -> TI (Sigma, Rho)
503 | unifyFun _   (TFun argT resT) = return (argT, resT)
504 | unifyFun pos tau = do
505 |     argT <- newMetaVar pos CNone 'a'
506 |     resT <- newMetaVar pos CNone 'b'
507 |     unify tau (withAnn pos $ TFunF argT resT)
508 |     return (argT, resT)
509 | 
510 | -- used by the Repl
511 | tcDecl :: Pos -> Bind Name -> Maybe Type -> Exp -> TI TypeEnv
512 | tcDecl pos b Nothing e = do
513 |    t <- tcRho e Nothing
514 |    binds <- tcBinds pos b (Just t) >>= mapM (inferSigma pos)
515 |    extendEnv binds (asks tiTypeEnv)
516 | tcDecl pos b (Just varT) e = do
517 |    varT  <- instWildcards varT
518 |    t <- tcRho e Nothing
519 |    subsCheck pos t varT
520 |    binds <- tcBinds pos b $ Just varT
521 |    extendEnv binds (asks tiTypeEnv)
522 | 
523 | tcPrim :: Pos -> Prim -> Type
524 | tcPrim pos prim = annotate pos $ case prim of
525 |   Int{}                  -> TInt
526 |   Dbl{}                  -> TDbl
527 |   Bool{}                 -> TBool
528 |   Char{}                 -> TChar
529 |   Text{}                 -> TText
530 |   Show                   ->
531 |     -- use an Eq constraint, to prevent attempting to show lambdas
532 |     let a = newTyVar (CStar CEq) 'a'
533 |     in TForAll [a] $ TFun (TVar a) TText
534 |   Trace                  ->
535 |     let a = newTyVar CNone 'a'
536 |     in TForAll [a] $ TFun (TFun TText (TVar a))
537 |                           (TVar a)
538 |   ErrorPrim              ->
539 |     let a = newTyVar CNone 'a'
540 |     in TForAll [a] $ TFun TText (TVar a)
541 | 
542 |   ArithPrim{}            ->
543 |     binOp  $ newTyVar (CStar CNum) 'a'
544 |   RelPrim{}              ->
545 |     binOpB $ newTyVar (CStar COrd) 'a'
546 | 
547 |   Not                    -> TFun TBool TBool
548 |   And                    -> TFun TBool (TFun TBool TBool)
549 |   Or                     -> TFun TBool (TFun TBool TBool)
550 | 
551 |   Eq                     -> binOpB $ newTyVar (CStar CEq) 'a'
552 |   NEq                    -> binOpB $ newTyVar (CStar CEq) 'a'
553 | 
554 |   Double                 -> TFun TInt TDbl
555 |   Floor                  -> TFun TDbl TInt
556 |   Ceiling                -> TFun TDbl TInt
557 |   Abs                    ->
558 |       unOp  $ newTyVar (CStar CNum) 'a'
559 |   Neg                    ->
560 |       unOp  $ newTyVar (CStar CNum) 'a'
561 |   Mod                    ->
562 |     TFun TInt (TFun TInt TInt)
563 |   FixPrim                ->
564 |     let a = newTyVar CNone 'a'
565 |     in TForAll [a] $ TFun (TFun (TVar a) (TVar a)) (TVar a)
566 |   FwdComp                ->   -- forward composition operator
567 |     let a = newTyVar CNone 'a' -- (a -> b) -> (b -> c) -> a -> c
568 |         b = newTyVar CNone 'b'
569 |         c = newTyVar CNone 'c'
570 |     in TForAll [a,b,c] $ TFun (TFun (TVar a) (TVar b))
571 |                                     (TFun (TFun (TVar b) (TVar c))
572 |                                           (TFun (TVar a) (TVar c)))
573 |   BwdComp                ->   -- backward composition operator
574 |     let a = newTyVar CNone 'a' -- (b -> c) -> (a -> b) -> a -> c
575 |         b = newTyVar CNone 'b'
576 |         c = newTyVar CNone 'c'
577 |     in TForAll [a,b,c] $ TFun (TFun (TVar b) (TVar c))
578 |                                     (TFun (TFun (TVar a) (TVar b))
579 |                                           (TFun (TVar a) (TVar c)))
580 |   Pack                   -> TFun (TList TChar) TText
581 |   Unpack                 -> TFun TText (TList TChar)
582 |   TextAppend             -> TFun TText (TFun TText TText)
583 |   Cond                   ->
584 |     let a = newTyVar CNone 'a'
585 |     in TForAll [a] $ TFun TBool
586 |                                 (TFun (TVar a)
587 |                                       (TFun (TVar a) (TVar a)))
588 |   ListEmpty              ->
589 |     let a = newTyVar CNone 'a'
590 |     in TForAll [a] $ TList (TVar a)
591 |   ListCons               ->
592 |     let a = newTyVar CNone 'a'
593 |     in TForAll [a] $ TFun (TVar a)
594 |                           (TFun (TList (TVar a))
595 |                                 (TList (TVar a)))
596 |   ListUncons             ->
597 |     let a     = newTyVar CNone 'a'
598 |         listT = TList (TVar a)
599 |         resT  = TRecord $ TRowExtend "head" (TVar a)
600 |                         $ TRowExtend "tail" listT
601 |                         $ TRowEmpty
602 |         unitT = TRecord TRowEmpty
603 |     in TForAll [a] $ TFun listT
604 |                           (TVariant $ TRowExtend "Just" resT
605 |                                     $ TRowExtend "Nothing" unitT
606 |                                     $ TRowEmpty)
607 |   ListAppend             ->
608 |     let a = newTyVar CNone 'a'
609 |     in TForAll [a] $ TFun (TList (TVar a))
610 |                           (TFun (TList (TVar a))
611 |                                 (TList (TVar a)))
612 | 
613 |   RecordEmpty            -> TRecord TRowEmpty
614 |   (RecordSelect label)   ->
615 |     let a = newTyVar CNone 'a'
616 |         r = newTyVar (lacks [label]) 'r'
617 |     in TForAll [a,r] $
618 |         TFun (TRecord $ TRowExtend label (TVar a) (TVar r)) (TVar a)
619 |   (RecordExtend label)   ->
620 |     let a = newTyVar CNone 'a'
621 |         r = newTyVar (lacks [label]) 'r'
622 |     in TForAll [a,r] $
623 |         TFun (TVar a)
624 |              (TFun (TRecord (TVar r))
625 |                    (TRecord $ TRowExtend label (TVar a) (TVar r)))
626 |   (RecordRestrict label) ->
627 |     let a = newTyVar CNone 'a'
628 |         r = newTyVar (lacks [label]) 'r'
629 |     in TForAll [a,r] $
630 |         TFun (TRecord $ TRowExtend label (TVar a) (TVar r))
631 |              (TRecord (TVar r))
632 |   Absurd                 ->
633 |     let a = newTyVar CNone 'a'
634 |     in TForAll [a] $ TFun (TVariant TRowEmpty) (TVar a)
635 |   (VariantInject label)  ->  -- dual of record select
636 |     let a = newTyVar CNone 'a'
637 |         r = newTyVar (lacks [label]) 'r'
638 |     in TForAll [a, r] $
639 |         TFun (TVar a)
640 |              (TVariant $ TRowExtend label (TVar a) (TVar r))
641 |            -- a -> <l:a|r>
642 |   (VariantEmbed label)   ->  -- dual of record restrict
643 |     let a = newTyVar CNone 'a'
644 |         r = newTyVar (lacks [label]) 'r'
645 |     in TForAll [a, r] $
646 |         TFun (TVariant (TVar r))
647 |              (TVariant $ TRowExtend label (TVar a) (TVar r))
648 |            -- <r> -> <l:a|r>
649 |   (VariantElim label)    ->
650 |     let a = newTyVar CNone 'a'
651 |         b = newTyVar CNone 'b'
652 |         r = newTyVar (lacks [label]) 'r'
653 |     in TForAll [a, b, r] $
654 |         TFun (TFun (TVar a) (TVar b))
655 |              (TFun (TFun (TVariant (TVar r)) (TVar b))
656 |                    (TFun (TVariant $ TRowExtend label (TVar a) (TVar r))
657 |                          (TVar b)))
658 |                   --  (a -> b) -> (<r> -> b) -> <l:a|r> -> b
659 | 
660 |   where
661 |     binOpB tv = TForAll [tv] $ TFun ty (TFun ty TBool)
662 |       where ty = TVar tv
663 |     binOp tv  = TForAll [tv] $ TFun ty (TFun ty ty)
664 |       where ty = TVar tv
665 |     unOp tv   = TForAll [tv] $ TFun ty ty
666 |       where ty = TVar tv
667 | 
668 | throwError' :: [Doc] -> TI a
669 | throwError' = throwError . show . vcat
670 | 


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