├── test ├── Spec.hs ├── UntypedSpec.hs ├── InferSpec.hs └── ParserSpec.hs ├── Setup.hs ├── screenshot.gif ├── Paths_ntha.hs ├── .gitmodules ├── runexample.sh ├── examples ├── module.ntha ├── misc.ntha ├── kanren.ntha ├── symbolic_computation.ntha └── type_infer.ntha ├── .gitignore ├── src ├── Ntha.hs ├── Ntha │ ├── Z3 │ │ ├── Logic.hs │ │ ├── Encoding.hs │ │ ├── Context.hs │ │ ├── Assertion.hs │ │ └── Class.hs │ ├── State.hs │ ├── Type │ │ ├── TypeScope.hs │ │ ├── Refined.hs │ │ ├── Type.hs │ │ └── Infer.hs │ ├── Parser │ │ ├── Lexer.x │ │ └── Parser.y │ ├── Core │ │ ├── Prelude.hs │ │ └── Ast.hs │ └── Runtime │ │ ├── Value.hs │ │ └── Eval.hs └── Untyped │ ├── Main.hs │ ├── Eval.hs │ ├── Builtins.hs │ └── Syntax.hs ├── stack.yaml ├── .travis.yml ├── LICENSE ├── ntha.cabal ├── app └── Main.hs ├── lib └── std.ntha └── README.md /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /screenshot.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/swr1bm86/Ntha/HEAD/screenshot.gif -------------------------------------------------------------------------------- /Paths_ntha.hs: -------------------------------------------------------------------------------- 1 | module Paths_ntha where 2 | 3 | getDataFileName :: FilePath -> IO FilePath 4 | getDataFileName = return 5 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "z3-haskell"] 2 | path = z3-haskell 3 | url = https://github.com/izgzhen/z3-haskell 4 | [submodule "z3-encoding"] 5 | path = z3-encoding 6 | url = https://github.com/izgzhen/z3-encoding 7 | -------------------------------------------------------------------------------- /runexample.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ./ntha ./examples/symbolic_computation.ntha 4 | ./ntha ./examples/type_infer.ntha 5 | ./ntha ./examples/kanren.ntha 6 | ./ntha ./examples/misc.ntha 7 | ./ntha ./examples/module.ntha 8 | -------------------------------------------------------------------------------- /examples/module.ntha: -------------------------------------------------------------------------------- 1 | (import examples.misc) 2 | 3 | (let f5 (fact 5)) 4 | (asserteq f5 120) 5 | (print (int2str f5)) 6 | 7 | (let fw5 (fact-wrap 5)) 8 | (asserteq fw5 120) 9 | (print (int2str fw5)) 10 | 11 | (let fc5 (factc 5)) 12 | (asserteq fc5 120) 13 | (print (int2str fc5)) -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | src/highlight.js 20 | src/style.css 21 | -------------------------------------------------------------------------------- /src/Ntha.hs: -------------------------------------------------------------------------------- 1 | module Ntha 2 | ( module Ntha.Core.Ast 3 | , module Ntha.Runtime.Value 4 | , module Ntha.Type.Type 5 | , module Ntha.Type.TypeScope 6 | , module Ntha.Type.Refined 7 | , module Ntha.Runtime.Eval 8 | , module Ntha.Type.Infer 9 | , module Ntha.Core.Prelude 10 | , module Ntha.Parser.Parser 11 | ) where 12 | 13 | import Ntha.Core.Ast 14 | import Ntha.Runtime.Value(ValueScope(..), Value(..)) 15 | import Ntha.Type.Type 16 | import Ntha.Type.TypeScope 17 | import Ntha.Type.Refined 18 | import Ntha.Runtime.Eval 19 | import Ntha.Type.Infer 20 | import Ntha.Core.Prelude 21 | import Ntha.Parser.Parser 22 | -------------------------------------------------------------------------------- /src/Ntha/Z3/Logic.hs: -------------------------------------------------------------------------------- 1 | -- | Predicates 2 | 3 | module Ntha.Z3.Logic (Pred(..)) where 4 | 5 | data Pred t ty a where 6 | PTrue :: Pred t ty a 7 | PFalse :: Pred t ty a 8 | PConj :: Pred t ty a -> Pred t ty a -> Pred t ty a 9 | PDisj :: Pred t ty a -> Pred t ty a -> Pred t ty a 10 | PXor :: Pred t ty a -> Pred t ty a -> Pred t ty a 11 | PNeg :: Pred t ty a -> Pred t ty a 12 | PForAll :: String -> ty -> Pred t ty a -> Pred t ty a 13 | PExists :: String -> ty -> Pred t ty a -> Pred t ty a 14 | PExists2 :: String -> String -> ty -> Pred t ty a -> Pred t ty a 15 | PImpli :: Pred t ty a -> Pred t ty a -> Pred t ty a 16 | PIff :: Pred t ty a -> Pred t ty a -> Pred t ty a 17 | PAssert :: a -> Pred t ty a 18 | deriving (Show) 19 | -------------------------------------------------------------------------------- /src/Untyped/Main.hs: -------------------------------------------------------------------------------- 1 | module Untyped.Main where 2 | 3 | import Control.Monad 4 | import Control.Monad.Except 5 | import Control.Monad.State 6 | import System.IO 7 | import Untyped.Builtins 8 | import Untyped.Eval 9 | import Untyped.Syntax 10 | 11 | main :: IO () 12 | main = do _ <- runExceptT $ evalStateT repl initialCtx 13 | return () 14 | 15 | repl :: StateT Context Error () 16 | repl = do liftIO $ putStr "λ> " 17 | liftIO $ hFlush stdout 18 | x <- liftIO getLine 19 | unless (x == "(quit)") $ 20 | do expr <- parseExpr x 21 | result <- eval expr 22 | liftIO $ print result 23 | repl 24 | `catchError` (\e -> do liftIO $ putStrLn e 25 | repl) 26 | -------------------------------------------------------------------------------- /src/Ntha/State.hs: -------------------------------------------------------------------------------- 1 | module Ntha.State where 2 | 3 | import Data.IORef 4 | import System.IO.Unsafe (unsafePerformIO) 5 | 6 | {-# NOINLINE createState #-} 7 | createState :: a -> IORef a 8 | createState = unsafePerformIO . newIORef 9 | 10 | {-# NOINLINE readState #-} 11 | readState :: IORef a -> a 12 | readState = unsafePerformIO . readIORef 13 | 14 | type Infer a = IO a 15 | 16 | currentId :: IORef Int 17 | currentId = createState 0 18 | 19 | nextId :: Infer Int 20 | nextId = do 21 | v <- readIORef currentId 22 | writeIORef currentId (v + 1) 23 | return v 24 | 25 | resetId :: Infer () 26 | resetId = writeIORef currentId 0 27 | 28 | currentUniqueName :: IORef Char 29 | currentUniqueName = createState 'α' 30 | 31 | nextUniqueName :: Infer String 32 | nextUniqueName = do 33 | char <- readIORef currentUniqueName 34 | if char == 'ω' 35 | then resetUniqueName 36 | else writeIORef currentUniqueName $ succ char 37 | return [char] 38 | 39 | resetUniqueName :: Infer () 40 | resetUniqueName = writeIORef currentUniqueName 'α' 41 | -------------------------------------------------------------------------------- /test/UntypedSpec.hs: -------------------------------------------------------------------------------- 1 | module UntypedSpec where 2 | 3 | import Untyped.Eval 4 | import Untyped.Syntax 5 | import Untyped.Builtins 6 | import Control.Monad.State 7 | import Control.Monad.Except 8 | import Test.Hspec 9 | 10 | toplevel' :: [String] -> StateT Context Error String 11 | toplevel' [] = return "empty expressions" 12 | toplevel' [x] = do expr <- parseExpr x 13 | result <- eval expr 14 | return $ show result 15 | toplevel' (x:xs) = do expr <- parseExpr x 16 | _ <- eval expr 17 | toplevel' xs 18 | 19 | toplevel :: [String] -> IO (Either String String) 20 | toplevel es = runExceptT $ evalStateT (toplevel' es) initialCtx 21 | 22 | spec :: Spec 23 | spec = describe "untyped test" $ 24 | it "should evaluate untyped expressions" $ do 25 | r1 <- toplevel ["(set fac (fn (n) (if (eq n 1) 1 (* n (fac (- n 1))))))", "(fac 5)"] 26 | r1 `shouldBe` Right "120" 27 | r2 <- toplevel ["(set fib (fn (n) (if (eq n 0) 1 (if (eq n 1) 1 (+ (fib (- n 1)) (fib (- n 2)))))))", "(fib 5)"] 28 | r2 `shouldBe` Right "8" 29 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: nightly-2016-10-07 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | #- './z3-haskell' 10 | #- './z3-encoding' 11 | 12 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 13 | extra-deps: 14 | - z3-4.1.0 15 | 16 | # Override default flag values for local packages and extra-deps 17 | flags: {} 18 | 19 | # Extra package databases containing global packages 20 | extra-package-dbs: [] 21 | 22 | # Control whether we use the GHC we find on the path 23 | # system-ghc: true 24 | 25 | # Require a specific version of stack, using version ranges 26 | # require-stack-version: -any # Default 27 | # require-stack-version: >= 0.1.4.0 28 | 29 | # Override the architecture used by stack, especially useful on Windows 30 | # arch: i386 31 | # arch: x86_64 32 | 33 | # Extra directories used by stack for building 34 | # extra-include-dirs: [/path/to/dir] 35 | # extra-lib-dirs: [/path/to/dir] 36 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.stack 8 | 9 | before_install: 10 | - mkdir -p ~/.local/bin 11 | - export PATH=~/.local/bin:$PATH 12 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar -xzO --wildcards '*/stack' > ~/.local/bin/stack 13 | - chmod a+x ~/.local/bin/stack 14 | # FIXME since upstream of Z3-encoding updated and refactored, need to catch up later. 15 | # - git submodule update 16 | 17 | matrix: 18 | include: 19 | - env: CABALVER=1.22 GHCVER=7.10.3 20 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3],sources: [hvr-ghc]}} 21 | 22 | install: 23 | - stack -j 2 setup --no-terminal 24 | - stack -j 2 build --only-snapshot --no-terminal 25 | 26 | script: 27 | - wget https://github.com/Z3Prover/z3/archive/z3-4.4.1.zip 28 | - unzip z3-4.4.1.zip 29 | - cd z3-z3-4.4.1 30 | - python scripts/mk_make.py --prefix=`pwd`/install 31 | - cd build 32 | - make 33 | - make install 34 | - cd ../install/lib 35 | - export LD_LIBRARY_PATH=`pwd` 36 | - stack clean && stack test --extra-include-dirs $TRAVIS_BUILD_DIR/z3-z3-4.4.1/install/include --extra-lib-dirs $TRAVIS_BUILD_DIR/z3-z3-4.4.1/install/lib 37 | 38 | -------------------------------------------------------------------------------- /src/Ntha/Type/TypeScope.hs: -------------------------------------------------------------------------------- 1 | module Ntha.Type.TypeScope where 2 | 3 | import Ntha.Core.Ast 4 | import Ntha.Type.Type 5 | 6 | import Prelude hiding (lookup) 7 | import qualified Data.Map as M 8 | 9 | type TypeEnv = M.Map EName Type 10 | type ParentScope = TypeScope 11 | 12 | data TypeScope = TypeScope (Maybe ParentScope) TypeEnv 13 | 14 | createEmptyScope :: TypeScope 15 | createEmptyScope = TypeScope Nothing M.empty 16 | 17 | createScopeWithParent :: ParentScope -> TypeScope 18 | createScopeWithParent parent = TypeScope (Just parent) M.empty 19 | 20 | createScope :: ParentScope -> TypeEnv -> TypeScope 21 | createScope parent env = TypeScope (Just parent) env 22 | 23 | insert :: EName -> Type -> TypeScope -> TypeScope 24 | insert name t (TypeScope parent env) = TypeScope parent (M.insert name t env) 25 | 26 | lookup :: EName -> TypeScope -> Maybe Type 27 | lookup name (TypeScope parent env) = case M.lookup name env of 28 | Just t -> Just t 29 | Nothing -> case parent of 30 | Just p -> lookup name p 31 | Nothing -> Nothing 32 | 33 | -- create a child type scope of current parent type scope 34 | child :: ParentScope -> TypeScope 35 | child = createScopeWithParent 36 | 37 | instance Show TypeScope where 38 | show (TypeScope parent env) = 39 | (show . M.toList) env ++ case parent of 40 | Just p -> " -> " ++ show p 41 | Nothing -> " -| " 42 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 zjhmale 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /src/Untyped/Eval.hs: -------------------------------------------------------------------------------- 1 | module Untyped.Eval where 2 | 3 | import Control.Monad.Except 4 | import Control.Monad.State 5 | import qualified Data.Map as M 6 | import Untyped.Syntax 7 | 8 | eval :: Expr -> Result 9 | eval r@(Int _) = return r 10 | eval r@(Fn _ _) = return r 11 | eval r@(Special _ _) = return r 12 | eval (Symbol s) = do context <- get 13 | lookupSymbol context 14 | where lookupSymbol (Ctx sym_table parentCtx) = 15 | if s `M.member` sym_table 16 | then return (sym_table M.! s) 17 | else case parentCtx of 18 | Nothing -> throwError ("Symbol " ++ s ++ " is unbound.") 19 | (Just parent) -> lookupSymbol parent 20 | eval r@(List []) = return r 21 | eval (List (x:xs)) = do fn <- eval x 22 | apply fn 23 | where apply (Special f expectedArgs) = apply' expectedArgs xs f 24 | apply (Fn f expectedArgs) = do args <- mapM eval xs 25 | apply' expectedArgs args f 26 | apply _ = throwError "First element of a list should be a function or a special form." 27 | apply' expectedArgs args f = do modify pushContext 28 | applyArgsToContext expectedArgs args 29 | result <- f 30 | modify popContext 31 | return result 32 | -- like (+ 1 2 3) will fold + on the whole list of arguments 33 | applyArgsToContext ("...":_) args = updateSymbol "..." (List args) 34 | -- e.g. (λ x y → x + y) 1 2 will put {x: 1, y: 2} in the context 35 | applyArgsToContext (earg:expectedArgs) (arg:args) = do updateSymbol earg arg 36 | applyArgsToContext expectedArgs args 37 | applyArgsToContext _ _ = return () 38 | -------------------------------------------------------------------------------- /src/Ntha/Z3/Encoding.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Prviding some Z3 encoding for certain language constructs 3 | -- Require a Class.SMT context to work 4 | 5 | module Ntha.Z3.Encoding ( 6 | -- ** Heterogenous list, a hack to encode different "term" into a list 7 | -- Used to encode function argument list 8 | HeteroList(..), 9 | -- ** encode function application 10 | encodeApp, 11 | -- ** encode datatype definition 12 | encodeDataType 13 | ) where 14 | 15 | import Ntha.Z3.Class 16 | import Z3.Monad hiding (mkMap, App) 17 | 18 | data HeteroList where 19 | Cons :: forall a. (Z3Sorted a, Z3Encoded a) => a -> HeteroList -> HeteroList 20 | Nil :: HeteroList 21 | 22 | instance Eq HeteroList where 23 | Nil == Nil = True 24 | Cons _ h1 == Cons _ h2 = h1 == h2 25 | _ == _ = False 26 | 27 | mapH :: (forall a. (Z3Sorted a, Z3Encoded a) => a -> b) -> HeteroList -> [b] 28 | mapH _ Nil = [] 29 | mapH f (Cons a l) = f a : mapH f l 30 | 31 | encodeApp :: SMT m e => String -> HeteroList -> Sort -> m e AST 32 | encodeApp fname args retSort = do 33 | paramSorts <- sequence $ mapH sort args 34 | sym <- mkStringSymbol fname 35 | decl <- mkFuncDecl sym paramSorts retSort 36 | argASTs <- sequence $ mapH encode args 37 | mkApp decl argASTs 38 | 39 | encodeDataType :: SMT m e => Z3Sorted ty => (String, [(String, [(String, ty)])]) -> m e Sort 40 | encodeDataType (tyName, alts) = do 41 | constrs <- mapM (\(consName, fields) -> do 42 | consSym <- mkStringSymbol consName 43 | -- recognizer. e.g. is_None None = True, is_None (Some _) = False 44 | recogSym <- mkStringSymbol ("is_" ++ consName) 45 | flds <- flip mapM fields $ \(fldName, fldTy) -> do 46 | symFld <- mkStringSymbol fldName 47 | s <- sort fldTy 48 | return (symFld, Just s, -1) -- XXX: non-rec 49 | mkConstructor consSym recogSym flds 50 | ) alts 51 | sym <- mkStringSymbol tyName 52 | mkDatatype sym constrs 53 | -------------------------------------------------------------------------------- /src/Ntha/Z3/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | -- | A concrete context implement SMT provided *for convenience* 4 | 5 | module Ntha.Z3.Context (Z3SMT) where 6 | 7 | import Ntha.Z3.Class 8 | import Ntha.Z3.Encoding 9 | import Z3.Monad 10 | 11 | import Control.Monad.State 12 | import Control.Monad.Except 13 | import qualified Data.Map as M 14 | 15 | data SMTContext e = SMTContext { 16 | -- | Bind local variables introduced by qualifiers to de brujin index in Z3 17 | _qualifierContext :: M.Map String (AST, Sort), 18 | -- | From type name to Z3 sort 19 | _datatypeCtx :: M.Map String Sort, 20 | -- | Counter used to generate globally unique ID 21 | _counter :: Int, 22 | -- | Extra field reserved for extension 23 | _extra :: e 24 | } deriving (Show, Eq) 25 | 26 | newtype Z3SMT e a = Z3SMT { unZ3SMT :: ExceptT String (StateT (SMTContext e) Z3) a } 27 | deriving (Monad, Applicative, Functor, MonadState (SMTContext e), MonadIO, MonadError String) 28 | 29 | instance MonadZ3 (Z3SMT e) where 30 | getSolver = Z3SMT (lift (lift getSolver)) 31 | getContext = Z3SMT (lift (lift getContext)) 32 | 33 | instance SMT Z3SMT e where 34 | genFreshId = do 35 | i <- _counter <$> get 36 | modify (\ctx -> ctx { _counter = i + 1 }) 37 | return i 38 | 39 | runSMT datatypes e smt = evalZ3With Nothing opts m 40 | where 41 | smt' = do 42 | sorts <- mapM encodeDataType datatypes 43 | let datatypeCtx = M.fromList (zip (map fst datatypes) sorts) 44 | modify $ \ctx -> ctx { _datatypeCtx = datatypeCtx } 45 | smt 46 | 47 | -- XXX: not sure what does this option mean 48 | opts = opt "MODEL" True 49 | m = evalStateT (runExceptT (unZ3SMT smt')) 50 | (SMTContext M.empty M.empty 0 e) 51 | 52 | bindQualified x idx s = modify $ \ctx -> 53 | ctx { _qualifierContext = M.insert x (idx, s) (_qualifierContext ctx) } 54 | 55 | getQualifierCtx = _qualifierContext <$> get 56 | 57 | getDataTypeCtx = _datatypeCtx <$> get 58 | 59 | getExtra = _extra <$> get 60 | 61 | modifyExtra f = modify $ \ctx -> ctx { _extra = f (_extra ctx) } 62 | -------------------------------------------------------------------------------- /src/Ntha/Z3/Assertion.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Assertions provided by libraries *for convenience* 3 | -- It is not hard-coded into Z3.Logic.Pred 4 | -- 5 | 6 | module Ntha.Z3.Assertion (Assertion(..)) where 7 | 8 | import Ntha.Z3.Class 9 | import Ntha.Z3.Encoding() 10 | import Z3.Monad 11 | 12 | import qualified Data.Map as M 13 | import qualified Data.Set as S 14 | 15 | data Assertion where 16 | -- | k is mapped to v in (m :: M.Map k v) 17 | -- XXX: m should be any "term", too strong now 18 | InMap :: forall k v. (Z3Sorted k, Z3Encoded k, Z3Sorted v, Z3Reserved v) => k -> v -> M.Map k v -> Assertion 19 | -- | v is in s 20 | -- XXX: s should be any "term", too strong now 21 | InSet :: forall v. (Z3Encoded v, Z3Sorted v) => v -> S.Set v -> Assertion 22 | -- | All below are binary relationships 23 | -- XXX: Should make sure v1 ~ v2, too weak now 24 | Equal :: forall v1 v2. (Z3Encoded v1, Z3Encoded v2, Eq v1, Eq v2) => v1 -> v2 -> Assertion 25 | LessE :: forall v1 v2. (Z3Encoded v1, Z3Encoded v2, Eq v1, Eq v2) => v1 -> v2 -> Assertion 26 | GreaterE :: forall v1 v2. (Z3Encoded v1, Z3Encoded v2, Eq v1, Eq v2) => v1 -> v2 -> Assertion 27 | Less :: forall v1 v2. (Z3Encoded v1, Z3Encoded v2, Eq v1, Eq v2) => v1 -> v2 -> Assertion 28 | Greater :: forall v1 v2. (Z3Encoded v1, Z3Encoded v2, Eq v1, Eq v2) => v1 -> v2 -> Assertion 29 | 30 | instance Z3Encoded Assertion where 31 | encode (InMap k v m) = do 32 | kTm <- encode k 33 | vTm <- encode v 34 | mTm <- encode m 35 | lhs <- mkSelect mTm kTm 36 | mkEq lhs vTm 37 | encode (InSet e s) = do 38 | eTm <- encode e 39 | sTm <- encode s 40 | lhs <- mkSelect sTm eTm 41 | -- XXX: magic number 42 | one <- (mkIntSort >>= mkInt 1) 43 | mkEq one lhs 44 | encode (Equal t1 t2) = do 45 | a1 <- encode t1 46 | a2 <- encode t2 47 | mkEq a1 a2 48 | encode (LessE t1 t2) = do 49 | a1 <- encode t1 50 | a2 <- encode t2 51 | mkLe a1 a2 52 | encode (GreaterE t1 t2) = do 53 | a1 <- encode t1 54 | a2 <- encode t2 55 | mkGe a1 a2 56 | encode (Less t1 t2) = do 57 | a1 <- encode t1 58 | a2 <- encode t2 59 | mkLt a1 a2 60 | encode (Greater t1 t2) = do 61 | a1 <- encode t1 62 | a2 <- encode t2 63 | mkGt a1 a2 64 | -------------------------------------------------------------------------------- /src/Untyped/Builtins.hs: -------------------------------------------------------------------------------- 1 | module Untyped.Builtins where 2 | 3 | import Control.Monad.State 4 | import Control.Monad.Except 5 | import qualified Data.Map as M 6 | import Untyped.Eval 7 | import Untyped.Syntax 8 | 9 | arithmeticFn :: (Integer -> Integer -> Integer) 10 | -> StateT Context Error Expr 11 | arithmeticFn f = do (List args) <- getSymbol "..." 12 | binaryFn f args 13 | 14 | binaryFn :: (Integer -> Integer -> Integer) -> [Expr] -> Result 15 | binaryFn op args = return $ foldl1 (binaryFnAux op) args 16 | where binaryFnAux op' (Int i) (Int j) = Int (i `op'` j) 17 | binaryFnAux _ _ _ = Int 0 18 | 19 | eqFn :: StateT Context Error Expr 20 | eqFn = do (List args) <- getSymbol "..." 21 | return $ foldl1 (\(Int a) (Int b) -> Bool $ a == b) args 22 | 23 | setFormArgs :: [String] 24 | setFormArgs = ["symbol", "value"] 25 | 26 | setForm :: StateT Context Error Expr 27 | setForm = do [Symbol s, e] <- getSymbols setFormArgs 28 | eval_e <- eval e 29 | updateSymbolInParent s eval_e 30 | return eval_e 31 | 32 | ifFormArgs :: [String] 33 | ifFormArgs = ["condition", "expr1", "expr2"] 34 | 35 | ifForm :: StateT Context Error Expr 36 | ifForm = do [condExpr, expr1, expr2] <- getSymbols ifFormArgs 37 | eval_cond <- eval condExpr 38 | case eval_cond of 39 | Bool v -> if v 40 | then eval expr1 41 | else eval expr2 42 | _ -> throwError "Cond of if should evaluate to a boolean value" 43 | 44 | fnArgs :: [String] 45 | fnArgs = ["args", "..."] 46 | 47 | -- | this get newFn part is use the power of lazyness 48 | -- so we can eval the function body until we really need it 49 | -- and at the same time all the arguments are all in the context 50 | -- including the function itself, so recursion is made trivial here. 51 | fn :: StateT Context Error Expr 52 | fn = do [List args, List body] <- getSymbols fnArgs 53 | let newFn = do evalBody <- mapM eval body 54 | case evalBody of 55 | [b] -> return b 56 | _ -> throwError "invalid function body" 57 | -- _ <- newFn -- this will definitely cause symbol not found exception 58 | return $ Fn newFn (map (\(Symbol arg) -> arg) args) 59 | 60 | initialCtx :: Context 61 | initialCtx = Ctx (M.fromList [ ("+", Fn (arithmeticFn (+)) ["..."]) 62 | , ("-", Fn (arithmeticFn (-)) ["..."]) 63 | , ("*", Fn (arithmeticFn (*)) ["..."]) 64 | , ("/", Fn (arithmeticFn div) ["..."]) 65 | , ("eq", Fn eqFn ["..."]) 66 | , ("set", Special setForm setFormArgs) 67 | , ("if", Special ifForm ifFormArgs) 68 | , ("fn", Special fn fnArgs) 69 | ]) 70 | Nothing 71 | 72 | getSymbol :: String -> Result 73 | getSymbol sym = eval $ Symbol sym 74 | 75 | getSymbols :: [String] -> StateT Context Error [Expr] 76 | getSymbols = mapM getSymbol 77 | -------------------------------------------------------------------------------- /src/Untyped/Syntax.hs: -------------------------------------------------------------------------------- 1 | -- just add this extentions to make stylish-haskell happy. 2 | {-# LANGUAGE ExplicitForAll #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | module Untyped.Syntax where 7 | 8 | import Control.Monad.Except 9 | import Control.Monad.State 10 | import Data.Functor.Identity 11 | import qualified Data.Map as M 12 | import qualified Text.Parsec.Prim as P 13 | import Text.ParserCombinators.Parsec 14 | 15 | data Expr = Int Integer 16 | | Bool Bool 17 | | Symbol String 18 | | Fn Function FunctionSignature 19 | | Special Function FunctionSignature 20 | | List [Expr] 21 | 22 | type FunctionSignature = [String] 23 | type Function = Result 24 | 25 | type SymbolTable = M.Map String Expr 26 | data Context = Ctx SymbolTable (Maybe Context) 27 | 28 | updateSymbol :: forall m. 29 | MonadState Context m => 30 | String -> Expr -> m () 31 | updateSymbol s eval_e = modify (\(Ctx sym_table parentCtx) -> Ctx (M.insert s eval_e sym_table) parentCtx) 32 | 33 | updateSymbolInParent :: forall m. 34 | MonadState Context m => 35 | String -> Expr -> m () 36 | updateSymbolInParent s eval_e = modify (\(Ctx sym_table parent_ctx) -> (Ctx sym_table (updatedCtx parent_ctx))) 37 | where updatedCtx (Just (Ctx sym_table ctx)) = Just (Ctx (M.insert s eval_e sym_table) ctx) 38 | updatedCtx Nothing = Nothing 39 | 40 | pushContext :: Context -> Context 41 | pushContext ctx = Ctx M.empty (Just ctx) 42 | 43 | popContext :: Context -> Context 44 | popContext ctx@(Ctx _ Nothing) = ctx 45 | popContext (Ctx _ (Just parentCtx)) = parentCtx 46 | 47 | type Error = ExceptT String IO 48 | type Result = StateT Context Error Expr 49 | 50 | instance Show Expr where 51 | show (Int x) = show x 52 | show (Bool x) = show x 53 | show (Symbol x) = x 54 | show (Fn _ _) = "" 55 | show (Special _ _) = "" 56 | show (List x) = "(" ++ unwords (map show x) ++ ")" 57 | 58 | parseInteger :: forall u. P.ParsecT String u Data.Functor.Identity.Identity Expr 59 | parseInteger = do sign <- option "" (string "-") 60 | number <- many1 digit 61 | return $ Int (read (sign++number)) 62 | 63 | parseSymbol :: forall u. P.ParsecT String u Identity Expr 64 | parseSymbol = do f <- firstAllowed 65 | r <- many (firstAllowed <|> digit) 66 | return $ Symbol (f:r) 67 | where firstAllowed = oneOf "+-*/" <|> letter 68 | 69 | parseExprAux :: P.ParsecT String () Identity Expr 70 | parseExprAux = try parseInteger <|> try parseSymbol <|> try parseList 71 | 72 | parseList :: GenParser Char () Expr 73 | parseList = do _ <- char '(' 74 | skipMany space 75 | x <- parseExprAux `sepEndBy` many1 space 76 | _ <- char ')' 77 | return $ List x 78 | 79 | parseExpr' :: P.ParsecT String () Identity Expr 80 | parseExpr' = do skipMany space 81 | x <- parseExprAux 82 | skipMany space 83 | eof 84 | return x 85 | 86 | parseExpr :: String -> Result 87 | parseExpr source = case Text.ParserCombinators.Parsec.parse parseExpr' "" source of 88 | Right x -> return x 89 | Left e -> throwError $ show e 90 | -------------------------------------------------------------------------------- /ntha.cabal: -------------------------------------------------------------------------------- 1 | name: ntha 2 | version: 0.1.3 3 | synopsis: A tiny statically typed functional programming language. 4 | description: Check out for documentation. 5 | homepage: https://github.com/zjhmale/ntha 6 | license: BSD3 7 | license-file: LICENSE 8 | author: zjhmale 9 | maintainer: zjhmale@gmail.com 10 | copyright: 2016 zjhmale 11 | category: Compiler 12 | , Language 13 | build-type: Simple 14 | -- extra-source-files: 15 | cabal-version: >=1.10 16 | extra-source-files: 17 | README.md 18 | data-files: 19 | lib/std.ntha 20 | examples/misc.ntha 21 | 22 | library 23 | hs-source-dirs: src 24 | exposed-modules: Ntha.Core.Ast 25 | , Ntha.Core.Prelude 26 | , Ntha.Runtime.Eval 27 | , Ntha.Runtime.Value 28 | , Ntha.Type.Type 29 | , Ntha.Type.TypeScope 30 | , Ntha.Type.Refined 31 | , Ntha.Type.Infer 32 | , Ntha.State 33 | , Ntha.Parser.Lexer 34 | , Ntha.Parser.Parser 35 | , Ntha.Z3.Assertion 36 | , Ntha.Z3.Class 37 | , Ntha.Z3.Context 38 | , Ntha.Z3.Encoding 39 | , Ntha.Z3.Logic 40 | , Ntha 41 | , Untyped.Syntax 42 | , Untyped.Eval 43 | , Untyped.Builtins 44 | , Untyped.Main 45 | build-depends: base >= 4.7 && < 5 46 | , containers 47 | , pretty 48 | , monad-loops 49 | , array 50 | , z3 >= 4.1.0 51 | , mtl >= 2.2 && < 2.3 52 | , parsec 53 | --, z3-encoding 54 | build-tools: happy 55 | , alex 56 | default-extensions: TupleSections 57 | , StandaloneDeriving 58 | , FlexibleInstances 59 | , FlexibleContexts 60 | , ScopedTypeVariables 61 | , MultiParamTypeClasses 62 | , RankNTypes 63 | , GADTs 64 | default-language: Haskell2010 65 | ghc-options: -Wall 66 | 67 | executable ntha 68 | hs-source-dirs: app 69 | main-is: Main.hs 70 | other-modules: Paths_ntha 71 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 72 | build-depends: base 73 | , ntha 74 | , containers 75 | , lens 76 | , haskeline 77 | , mtl 78 | default-language: Haskell2010 79 | 80 | test-suite ntha-test 81 | type: exitcode-stdio-1.0 82 | other-modules: EvalSpec 83 | , InferSpec 84 | , ParserSpec 85 | , UntypedSpec 86 | hs-source-dirs: test 87 | main-is: Spec.hs 88 | build-depends: base 89 | , ntha 90 | , hspec >= 1.3 91 | , containers 92 | , pretty 93 | , mtl >= 2.2 && < 2.3 94 | default-extensions: UnicodeSyntax 95 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 96 | default-language: Haskell2010 97 | 98 | source-repository head 99 | type: git 100 | location: https://github.com/zjhmale/ntha 101 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Ntha (Expr (..), 4 | Type (..), 5 | Value (..), 6 | TypeScope (..), 7 | ValueScope (..), 8 | EPath, 9 | analyze, 10 | assumptions, 11 | builtins, 12 | checker, 13 | eval, 14 | isImport, 15 | parseExpr) 16 | import Paths_ntha 17 | 18 | import System.Console.Haskeline 19 | import System.Environment 20 | import Control.Lens 21 | import Control.Monad (foldM) 22 | import Control.Monad.Trans 23 | import Data.List (intercalate) 24 | import qualified Control.Exception as E 25 | import qualified Data.Map as M 26 | import qualified Data.Set as S 27 | 28 | type Env = (TypeScope, ValueScope) 29 | 30 | emptyEnv :: (TypeScope, ValueScope) 31 | emptyEnv = (TypeScope Nothing M.empty, ValueScope Nothing M.empty) 32 | 33 | loadFile :: Env -> EPath -> IO Env 34 | loadFile env path = do 35 | file <- getDataFileName path 36 | fileContent <- readFile file 37 | (env', _, _) <- process' env $ parseExpr fileContent 38 | return env' 39 | 40 | loadImport :: Env -> Expr -> IO (Env, Expr) 41 | loadImport env expr = case expr of 42 | EProgram instructions -> do 43 | let imports = filter isImport instructions 44 | let continueAst = EProgram $ filter (not . isImport) instructions 45 | importEnv <- foldM (\ev (EImport path) -> loadFile ev path) env imports 46 | return (importEnv, continueAst) 47 | _ -> return (env, expr) 48 | 49 | loadLib :: IO Env 50 | loadLib = do 51 | assumps <- assumptions 52 | loadFile (assumps, builtins) "lib/std.ntha" 53 | 54 | process' :: Env -> Expr -> IO (Env, Value, Type) 55 | process' env expr = do 56 | ((importAssumps, importBuiltins), ast) <- loadImport env expr 57 | (assumps', t) <- analyze ast importAssumps S.empty 58 | checker ast assumps' 59 | let (builtins', v) = eval ast importBuiltins 60 | return ((assumps', builtins'), v, t) 61 | 62 | process :: Env -> String -> IO Env 63 | process env@(assumps, prevBuiltins) expr = 64 | E.catch (do 65 | (env', v, t) <- process' env $ parseExpr expr 66 | putStrLn $ show v ++ " : " ++ show t 67 | return env') 68 | (\(E.ErrorCall e) -> do 69 | putStrLn e 70 | return (assumps, prevBuiltins)) 71 | 72 | loop :: Env -> InputT IO Env 73 | loop env = do 74 | minput <- getInputLine "λ> " 75 | case minput of 76 | Nothing -> do 77 | outputStrLn "Goodbye." 78 | return emptyEnv 79 | Just input -> (liftIO $ process env input) >>= (\env' -> loop env') 80 | 81 | prologueMessage :: String 82 | prologueMessage = intercalate "\n" 83 | [" _ __ __ __", 84 | " / | / / / /_ / /_ ____ _", 85 | " / |/ / / __/ / __ \\ / __ `/", 86 | " / /| / / /_ / / / // /_/ /", 87 | " /_/ |_/ \\__/ /_/ /_/ \\__,_/", 88 | "" 89 | ] 90 | 91 | main :: IO Env 92 | main = do 93 | env <- loadLib 94 | args <- getArgs 95 | case (args ^? element 0) of 96 | Just arg -> if arg == "repl" 97 | then repl env 98 | else do 99 | file <- readFile arg 100 | process env file 101 | Nothing -> repl env 102 | where repl ev = do putStrLn prologueMessage 103 | runInputT defaultSettings (loop ev) 104 | -------------------------------------------------------------------------------- /src/Ntha/Parser/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | module Ntha.Parser.Lexer where 3 | import Ntha.Core.Ast (EName) 4 | import Data.Char (toUpper) 5 | } 6 | 7 | %wrapper "basic" 8 | 9 | $upper = [A-Z] 10 | $lower = [a-z] 11 | $greek = [α-ω] 12 | $digit = [0-9] 13 | $operator = [\+\-\*\/\%\=\>\<\∧\∨\¬\?\'\~\!\.] 14 | $chars = [$lower $upper $digit $operator $greek] 15 | $eol = [\n] 16 | 17 | tokens :- 18 | $eol ; 19 | $white+ ; 20 | ";;".* ; --comments 21 | -- TODO support multiline comments 22 | "data" { \_ -> DATA } 23 | "match" { \_ -> MATCH } 24 | "begin" { \_ -> BEGIN } 25 | "type" { \_ -> TYPE } 26 | "if" { \_ -> IF } 27 | "cond" { \_ -> COND } 28 | "else" { \_ -> ELSE } 29 | "monad" { \_ -> MONAD } 30 | "do" { \_ -> DO } 31 | "return" { \_ -> RETURN } 32 | "ƒ" | "fun" { \_ -> DEFUN } 33 | "λ" | "lambda" { \_ -> LAMBDA } 34 | "⇒" | "=>" | "→" | "->" { \_ -> RARROW } 35 | "⇐" | "<=" | "←" | "<-" { \_ -> LARROW } 36 | "[" { \_ -> LBRACKET } 37 | "]" { \_ -> RBRACKET } 38 | "(" { \_ -> LPAREN } 39 | ")" { \_ -> RPAREN } 40 | "{" { \_ -> LBRACE } 41 | "}" { \_ -> RBRACE } 42 | "_" { \_ -> WILDCARD } 43 | "." { \_ -> DOT } 44 | ":" $chars+ { \s -> KEYWORD (tail s) } 45 | ":" { \_ -> COLON } 46 | "∷" | "::" { \_ -> DOUBLECOLON } 47 | "|" { \_ -> BAR } 48 | "let" { \_ -> LET } 49 | "Z" { \_ -> NUMBERT } 50 | "B" { \_ -> BOOLT } 51 | "C" { \_ -> CHART } 52 | "S" { \_ -> STRT } 53 | "×" { \_ -> PRODUCT } 54 | "import" { \_ -> IMPORT } 55 | "true" | "false" { \s -> BOOLEAN (read ([toUpper (s!!0)] ++ tail s)) } 56 | $upper $chars* { \s -> CON s } 57 | $lower $chars* { \s -> VAR s } 58 | $greek { \s -> TVAR (s!!0) } 59 | \"[^\"]*\" { \s -> STRING ((tail . init) s) } 60 | '[^'\"]{1}' { \s -> CHAR ((head . tail . init) s) } 61 | $operator | "≠" | "≤" | "≥" { \s -> OPERATOR s } 62 | $digit+ { \s -> NUMBER (read s) } 63 | "-" $digit+ { \s -> NUMBER (read s) } 64 | 65 | { 66 | data Token = DATA 67 | | MATCH 68 | | BEGIN 69 | | TYPE 70 | | DEFUN 71 | | LAMBDA 72 | | MONAD 73 | | DO 74 | | RETURN 75 | | IF 76 | | COND 77 | | ELSE 78 | | RARROW 79 | | LARROW 80 | | LBRACKET 81 | | RBRACKET 82 | | LPAREN 83 | | RPAREN 84 | | LBRACE 85 | | RBRACE 86 | | WILDCARD 87 | | DOT 88 | | COLON 89 | | DOUBLECOLON 90 | | BAR 91 | | VAR EName 92 | | TVAR Char 93 | | CON EName -- constructor names or uppercase symbols 94 | | LET 95 | | NUMBERT 96 | | BOOLT 97 | | CHART 98 | | STRT 99 | | PRODUCT 100 | | IMPORT 101 | | KEYWORD String 102 | | OPERATOR String 103 | | BOOLEAN Bool 104 | | NUMBER Int 105 | | STRING String 106 | | CHAR Char 107 | deriving(Eq, Show) 108 | 109 | scanTokens = alexScanTokens 110 | } -------------------------------------------------------------------------------- /examples/misc.ntha: -------------------------------------------------------------------------------- 1 | ;; recursive function 2 | 3 | (ƒ penultimate [xs] 4 | (match xs 5 | ([] ⇒ 0) 6 | ([_] ⇒ 0) 7 | ([a _] ⇒ a) 8 | (_ :: t ⇒ (penultimate t)))) 9 | 10 | (fib : Z → Z) 11 | (ƒ fib [x] 12 | (match x 13 | (0 ⇒ 0) 14 | (1 ⇒ 1) 15 | (_ ⇒ (+ (fib (- x 1)) (fib (- x 2)))))) 16 | 17 | (asserteq (fib 5) 5) 18 | (print (int2str (fib 5))) 19 | 20 | (ƒ fibc [x] 21 | (cond 22 | ((= x 0) ⇒ 0) 23 | ((= x 1) ⇒ 1) 24 | (else ⇒ (+ (fibc (- x 1)) (fibc (- x 2)))))) 25 | 26 | (asserteq (fibc 5) 5) 27 | (print (int2str (fibc 5))) 28 | 29 | (ƒ fact [n] 30 | (if (≤ n 1) 31 | 1 32 | (* n (fact (- n 1))))) 33 | 34 | (let f5 (fact 5)) 35 | 36 | (asserteq f5 120) 37 | (print (int2str f5)) 38 | 39 | (ƒ fact-wrap [n] 40 | (let [fact (λ n → (if (≤ n 1) 41 | 1 42 | (* n (fact (- n 1)))))] 43 | (fact n))) 44 | 45 | (let f5 (fact-wrap 5)) 46 | (print (int2str f5)) 47 | 48 | (ƒ factc [n] 49 | (cond 50 | ((≤ n 1) → 1) 51 | (else → (* n (factc (- n 1)))))) 52 | 53 | (let fc5 (factc 5)) 54 | 55 | (asserteq fc5 120) 56 | (print (int2str fc5)) 57 | 58 | ;; record data type 59 | 60 | (let profile {:name "ntha" :age 3}) 61 | 62 | (asserteq (:name profile) "ntha") 63 | (print (:name profile)) 64 | 65 | ;; destructuring 66 | 67 | (let (a . b) (4 . "d")) 68 | 69 | (let d ((4 . true) . ("test" . 'c' . a))) 70 | 71 | (let ((_ . bool) . (_ . _ . _)) d) 72 | 73 | (asserteq bool true) 74 | (print (bool2str bool)) 75 | 76 | ;; algebraic data type and pattern matching 77 | 78 | (data Tree a Empty-Tree (Leaf a) (Node (Tree a) a (Tree a))) 79 | 80 | (let t (Node (Leaf 5) 4 (Leaf 3))) 81 | 82 | (depth : (Tree α) → Z) 83 | (ƒ depth 84 | [t] 85 | (match t 86 | (Empty-Tree => 0) 87 | ((Leaf _) => 1) 88 | ((Node l _ r) => (inc (max (depth l) (depth r)))))) 89 | 90 | (asserteq (depth t) 2) 91 | 92 | (print (int2str (depth t))) 93 | 94 | (asserteq (depth (Leaf 3)) 1) 95 | 96 | (print (int2str (depth (Leaf 3)))) 97 | 98 | (asserteq (depth Empty-Tree) 0) 99 | 100 | (print (int2str (depth Empty-Tree))) 101 | 102 | ;; lambda and high-order function 103 | 104 | (let l [1 2]) 105 | 106 | (ƒ double [x] (* 2 x)) 107 | 108 | (let ll1 (map double l)) 109 | 110 | (asserteq ll1 [2 4]) 111 | 112 | (let ll2 (map (λ x => (* 2 x)) l)) 113 | 114 | (asserteq ll2 [2 4]) 115 | 116 | (let l2 [[1 2 3] [4 5 6]]) 117 | 118 | (asserteq (map len l2) [3 3]) 119 | 120 | ;; curried function 121 | 122 | (ƒ add [x y] (+ x y)) 123 | 124 | (let inc (add 1)) 125 | 126 | (let three (inc 2)) 127 | 128 | (asserteq three 3) 129 | 130 | (print (int2str three)) 131 | 132 | ;; lexical scope 133 | 134 | (let a 3) 135 | 136 | (let f (λ x → (* a x))) 137 | 138 | (let a 5) 139 | 140 | (asserteq (f 5) 15) 141 | 142 | (print (int2str (f 5))) 143 | 144 | ;; monad 145 | 146 | (let m (do Maybe 147 | (a <- (Just 3)) 148 | (b <- (Just (+ a 3))) 149 | (return (* b 3)))) 150 | 151 | (asserteq m (Just 18)) 152 | 153 | (begin 154 | (let name "ntha") 155 | (print name) 156 | (print "language")) 157 | 158 | ;; negative number 159 | 160 | (asserteq (+ -1 2) 1) 161 | 162 | ;; letrec https://github.com/zjhmale/Ntha/issues/1 163 | 164 | (let [ev? (λ n → 165 | (match (λ n → (if (zero? n) false (ev? (dec n)))) 166 | (od? → (if (zero? n) true (od? (dec n)))))) 167 | od? (λ n → 168 | (match (λ n → (if (zero? n) true (od? (dec n)))) 169 | (ev? → (if (zero? n) false (ev? (dec n))))))] 170 | (begin (print (bool2str (ev? 11))) 171 | (print (bool2str (ev? 12))) 172 | (print (bool2str (od? 11))) 173 | (print (bool2str (od? 12))))) 174 | 175 | (id : α → α) 176 | (ƒ id [a] a) 177 | 178 | (asserteq (id 3) 3) 179 | (asserteq (id true) true) 180 | 181 | (asserteq ((λ(x: α) : α → x) 3) 3) 182 | (asserteq ((λ(x: α) : α → x) true) true) 183 | 184 | (let id' (λ(x: α) : α → x)) 185 | (asserteq (id' 3) 3) 186 | (asserteq (id' true) true) 187 | 188 | (foo : (x : Z | (> x 5)) → (z : Z | (> z 0))) 189 | (ƒ foo [x] (- x 5)) 190 | 191 | (add : (x : Z | (≥ x 3)) → (y : Z | (≥ y 3)) → (z : Z | (≥ z 6))) 192 | (ƒ add [x y] (+ x y)) 193 | 194 | (max : Z → Z → (z : Z | (∧ (≥ z x) (≥ z y)))) 195 | (ƒ max [x y] (if (≤ x y) y x)) 196 | -------------------------------------------------------------------------------- /src/Ntha/Core/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Ntha.Core.Prelude where 2 | 3 | import Ntha.Core.Ast 4 | import Ntha.Runtime.Value 5 | import Ntha.State 6 | import Ntha.Type.Type 7 | import Ntha.Type.TypeScope 8 | 9 | import Debug.Trace 10 | import qualified Data.Map as M 11 | 12 | mkTCon :: TypeConstructor -> Expr -> Type 13 | mkTCon (TypeConstructor name types) (EDataDecl _ t _ _) = TCon name types t 14 | mkTCon _ _ = error "not support" 15 | 16 | assumptions :: Infer TypeScope 17 | assumptions = do 18 | tvarA <- makeVariable 19 | tvarB <- makeVariable 20 | let name = "List" 21 | let vars = [tvarA] 22 | let dataType = TOper name vars 23 | let consConstructor = TypeConstructor "Cons" [tvarA, TOper "List" [tvarA]] 24 | let nilConstructor = TypeConstructor "Nil" [] 25 | let listData = EDataDecl "List" dataType vars [consConstructor, nilConstructor] 26 | return $ TypeScope Nothing $ 27 | M.fromList [("+", functionT [intT, intT] intT), 28 | ("-", functionT [intT, intT] intT), 29 | ("*", functionT [intT, intT] intT), 30 | ("/", functionT [intT, intT] intT), 31 | ("%", functionT [intT, intT] intT), 32 | ("=", functionT [tvarB, tvarB] boolT), 33 | ("≠", functionT [tvarB, tvarB] boolT), 34 | ("<", functionT [intT, intT] boolT), 35 | (">", functionT [intT, intT] boolT), 36 | ("≤", functionT [intT, intT] boolT), 37 | ("≥", functionT [intT, intT] boolT), 38 | ("∧", functionT [boolT, boolT] boolT), 39 | ("∨", functionT [boolT, boolT] boolT), 40 | ("¬", functionT [boolT] boolT), 41 | ("int2str", functionT [intT] strT), 42 | ("bool2str", functionT [boolT] strT), 43 | ("asserteq", functionT [tvarB, tvarB] unitT), 44 | ("print", functionT [strT] unitT), 45 | ("error", functionT [strT] tvarB), 46 | ("reverse", functionT [listT tvarB] (listT tvarB)), 47 | ("list?", functionT [tvarB] boolT), 48 | ("string?", functionT [tvarB] boolT), 49 | ("Cons", mkTCon consConstructor listData), 50 | ("Nil", mkTCon nilConstructor listData), 51 | ("inc", functionT [intT] intT), 52 | ("dec", functionT [intT] intT)] 53 | 54 | builtins :: ValueScope 55 | builtins = ValueScope Nothing $ 56 | M.fromList [("+", binFn (\(VNum a) (VNum b) -> (VNum $ a + b))), 57 | ("-", binFn (\(VNum a) (VNum b) -> (VNum $ a - b))), 58 | ("*", binFn (\(VNum a) (VNum b) -> (VNum $ a * b))), 59 | ("/", binFn (\(VNum a) (VNum b) -> (VNum $ a `div` b))), 60 | ("%", binFn (\(VNum a) (VNum b) -> (VNum $ a `mod` b))), 61 | ("=", binFn (\a b -> VBool $ a == b)), 62 | ("≠", binFn (\a b -> VBool $ a /= b)), 63 | ("<", binFn (\a b -> VBool $ a < b)), 64 | (">", binFn (\a b -> VBool $ a > b)), 65 | ("≤", binFn (\a b -> VBool $ a <= b)), 66 | ("≥", binFn (\a b -> VBool $ a >= b)), 67 | ("∧", binFn (\(VBool a) (VBool b) -> VBool $ a && b)), 68 | ("∨", binFn (\(VBool a) (VBool b) -> VBool $ a || b)), 69 | ("¬", Fn (\(VBool b) _ -> VBool $ not b)), 70 | ("int2str", Fn (\(VNum n) _ -> strV $ show n)), 71 | ("bool2str", Fn (\(VBool b) _ -> strV $ show b)), 72 | ("asserteq", binFn (\a b -> if a == b 73 | then VUnit 74 | else error $ show a ++ " and " ++ show b ++ " not equal.")), 75 | ("print", Fn (\v _ -> trace (desugerStrV v) VUnit)), 76 | ("error", Fn (\v _ -> error $ desugerStrV v)), 77 | ("reverse", Fn (\v _ -> reverseList v)), 78 | ("list?", Fn (\v _ -> case v of 79 | Adt "Cons" _ -> VBool True 80 | _ -> VBool False)), 81 | ("string?", Fn (\v _ -> VBool $ isString v)), 82 | ("Cons", binFn (\a b -> cons a b)), 83 | ("Nil", nil), 84 | ("inc", Fn (\(VNum n) _ -> VNum $ n + 1)), 85 | ("dec", Fn (\(VNum n) _ -> VNum $ n - 1))] 86 | -------------------------------------------------------------------------------- /lib/std.ntha: -------------------------------------------------------------------------------- 1 | (data Maybe a (Just a) Nothing) 2 | 3 | (monad Maybe {:return (λ x → (Just x)) 4 | :>>= (λ x f → (match x 5 | ((Just v) → (f v)) 6 | (Nothing → Nothing)))}) 7 | 8 | (ƒ len [l] 9 | (match l 10 | ([] ⇒ 0) 11 | (_ :: t ⇒ (+ 1 (len t))))) 12 | 13 | (ƒ map [f xs] 14 | (match xs 15 | ([] ⇒ []) 16 | (h :: t ⇒ ((f h) :: (map f t))))) 17 | 18 | (ƒ fold [f s xs] 19 | (match xs 20 | ([] ⇒ s) 21 | (h :: t ⇒ (fold f (f s h) t)))) 22 | 23 | (ƒ filter [f xs] 24 | (match xs 25 | ([] ⇒ []) 26 | (h :: t ⇒ (if (f h) 27 | (h :: (filter f t)) 28 | (filter f t))))) 29 | 30 | (ƒ range [x y] 31 | (let [rec-range (λ x y res ⇒ (if (> x y) 32 | res 33 | (rec-range x (- y 1) (y :: res))))] 34 | (rec-range x y []))) 35 | 36 | (ƒ lookup [name pairs] 37 | (match pairs 38 | ([] ⇒ Nothing) 39 | ((k . v) :: t ⇒ (if (= name k) 40 | (Just v) 41 | (lookup name t))))) 42 | 43 | (ƒ lookup! [default name pairs] 44 | (match pairs 45 | ([] ⇒ default) 46 | ((k . v) :: t ⇒ (if (= name k) 47 | v 48 | (lookup! default name t))))) 49 | 50 | (ƒ exists? 51 | [e l] 52 | (match l 53 | ([] → false) 54 | (h :: t → (if (= h e) 55 | true 56 | (exists? e t))))) 57 | 58 | (asserteq (exists? 3 [3 2 1]) true) 59 | (asserteq (exists? 33 [3 2 1]) false) 60 | 61 | (ƒ diff-list 62 | [l1 l2] 63 | (match l1 64 | ([] → []) 65 | (h :: t → (if (exists? h l2) 66 | (diff-list t l2) 67 | (h :: (diff-list t l2)))))) 68 | 69 | (asserteq (diff-list [3 2 1] [2 1]) [3]) 70 | 71 | (ƒ exists-map? 72 | [e m] 73 | (match (lookup e m) 74 | (Nothing → false) 75 | (_ → true))) 76 | 77 | (ƒ diff-map 78 | [m l] 79 | (match m 80 | ([] → []) 81 | ((k . v) :: t → (if (exists? k l) 82 | (diff-map t l) 83 | ((k . v) :: (diff-map t l)))))) 84 | 85 | (asserteq (diff-map [(1 . 2) (2 . 3)] [1]) [(2 . 3)]) 86 | (asserteq (diff-map [(1 . 2) (2 . 3) (3 . 3)] [1 2]) [(3 . 3)]) 87 | 88 | (ƒ union-map 89 | [m1 m2] 90 | (match m2 91 | ([] → m1) 92 | ((k . v) :: t → (if (exists-map? k m1) 93 | (union-map m1 t) 94 | ((k . v) :: (union-map m1 t)))))) 95 | 96 | (asserteq (union-map [(1 . 1) (3 . 3)] [(1 . 3) (3 . 1) (2 . 2)]) [(2 . 2) (1 . 1) (3 . 3)]) 97 | 98 | (ƒ map-map 99 | [f m] 100 | (match m 101 | ([] → []) 102 | ((k . v) :: t → ((k . (f v)) :: (map-map f t))))) 103 | 104 | (asserteq (map-map (λ x → (+ x 1)) [(1 . 1) (2 . 2)]) [(1 . 2) (2 . 3)]) 105 | 106 | (ƒ nub 107 | [l] 108 | (match l 109 | ([] → []) 110 | (h :: t → (if (exists? h t) 111 | (nub t) 112 | (h :: (nub t)))))) 113 | 114 | (asserteq (nub [1 2 3]) [1 2 3]) 115 | (asserteq (nub [1 1 1 2 2 3]) [1 2 3]) 116 | 117 | (ƒ conj [e l] 118 | (reverse (e :: (reverse l)))) 119 | 120 | (ƒ concat [l1 l2] 121 | (match l2 122 | ([] → l1) 123 | (h :: t → (concat (conj h l1) t)))) 124 | 125 | (asserteq (concat [1 2 3] [4 5 6]) [1 2 3 4 5 6]) 126 | (asserteq (concat "123" "456") "123456") 127 | 128 | (ƒ flatten [l] 129 | (match l 130 | ([] → []) 131 | (h :: t → (concat h (flatten t))))) 132 | 133 | (asserteq (flatten [[1] [2] [3]]) [1 2 3]) 134 | 135 | (ƒ empty? [l] 136 | (match l 137 | ([] → true) 138 | (_ → false))) 139 | 140 | (asserteq (empty? []) true) 141 | (asserteq (empty? [3]) false) 142 | 143 | (ƒ head [l] 144 | (match l 145 | ([] → (error "empty list")) 146 | (h :: _ → h))) 147 | 148 | (asserteq (head [1 2 3]) 1) 149 | 150 | (ƒ tail [l] 151 | (match l 152 | ([] → []) 153 | (_ :: t → t))) 154 | 155 | (asserteq (tail [1 2 3]) [2 3]) 156 | 157 | (ƒ take [n l] 158 | (if (> n 0) 159 | ((head l) :: (take (- n 1) (tail l))) 160 | [])) 161 | 162 | (asserteq (take 3 [1 2 3 4 5 6]) [1 2 3]) 163 | (asserteq (take 2 "_.x") "_.") 164 | 165 | (ƒ max [a b] (if (≥ a b) a b)) 166 | 167 | (ƒ zero? [n] (= n 0)) 168 | 169 | (ƒ fst 170 | [tuple] 171 | (match tuple 172 | ((v . _) → v) 173 | (_ → (error "need apply a tuple value")))) 174 | 175 | (ƒ snd 176 | [tuple] 177 | (match tuple 178 | ((_ . v) → v) 179 | (_ → (error "need apply a tuple value")))) 180 | -------------------------------------------------------------------------------- /examples/kanren.ntha: -------------------------------------------------------------------------------- 1 | (ƒ fail [x] []) 2 | (ƒ succeed [x] [x]) 3 | 4 | (asserteq (fail 3) []) 5 | (asserteq (succeed 3) [3]) 6 | 7 | (ƒ disj' [f1 f2] 8 | (λ x → (concat (f1 x) (f2 x)))) 9 | 10 | (ƒ disj* [args] 11 | (if (empty? args) 12 | fail 13 | (disj' (head args) 14 | (disj* (tail args))))) 15 | 16 | (ƒ conj' [f1 f2] 17 | (λ x → (flatten (map f2 (f1 x))))) 18 | 19 | (ƒ conj* [args] 20 | (match args 21 | ([] → succeed) 22 | ([a] → a) 23 | (h :: t → (conj' h (λ s → ((conj* t) s)))))) 24 | 25 | (let f1 (λ x → (succeed (concat x "foo")))) 26 | (let f2 (λ x → (succeed (concat x "bar")))) 27 | (let f3 (λ x → (succeed (concat x "baz")))) 28 | 29 | (asserteq ((disj* [f1 f2 f3]) "a ") ["a foo" "a bar" "a baz"]) 30 | (asserteq ((conj* [f1 f2 f3]) "a ") ["a foobarbaz"]) 31 | 32 | (asserteq ((disj* [(disj* [fail succeed]) 33 | (conj* [(disj* [(λ x → (succeed (+ x 1))) 34 | (λ x → (succeed (+ x 10)))]) 35 | (disj* [succeed succeed])])]) 36 | 100) 37 | [100 101 101 110 110]) 38 | 39 | (asserteq ((disj* [(disj* [fail succeed]) 40 | (disj* [(disj* [(λ x → (succeed (+ x 1))) 41 | (λ x → (succeed (+ x 10)))]) 42 | (disj* [succeed succeed])])]) 43 | 100) 44 | [100 101 110 100 100]) 45 | 46 | (asserteq ((disj* [(disj* [fail succeed]) 47 | (conj* [(disj* [(λ x → (succeed (+ x 1))) 48 | (λ x → (succeed (+ x 10)))]) 49 | (disj* [succeed fail])])]) 50 | 100) 51 | [100 101 110]) 52 | 53 | ;;logic variable 54 | (ƒ lvar [name] (concat "_." name)) 55 | 56 | (ƒ lvar? [var] 57 | (∧ (string? var) (= (take 2 var) "_."))) 58 | 59 | (asserteq (lvar? (lvar "ntha")) true) 60 | (asserteq (lvar? "ntha") false) 61 | 62 | (let va (lvar "a")) 63 | (let vb (lvar "b")) 64 | (let vc (lvar "c")) 65 | (let vd (lvar "d")) 66 | 67 | (let empty-subrule []) 68 | 69 | (ƒ extend-subrule [var val subrule] 70 | ((var . val) :: subrule)) 71 | 72 | (let s (extend-subrule (lvar "x") (lvar "y") empty-subrule)) 73 | (asserteq s [("_.x" . "_.y")]) 74 | 75 | (let s (extend-subrule (lvar "y") "1" s)) 76 | (asserteq s [("_.y" . "1") ("_.x" . "_.y")]) 77 | 78 | (ƒ lookup-subrule [var subrule] 79 | (if (¬ (lvar? var)) 80 | var 81 | (match (lookup var subrule) 82 | ((Just val) → (lookup-subrule val subrule)) 83 | (Nothing → var)))) 84 | 85 | (asserteq (lookup-subrule (lvar "y") s) "1") 86 | (asserteq (lookup-subrule (lvar "x") s) "1") 87 | 88 | (ƒ unify [t1 t2 subrule] 89 | (let [t1 (lookup-subrule t1 subrule) 90 | t2 (lookup-subrule t2 subrule)] 91 | (cond 92 | ((= t1 t2) → (Just s)) 93 | ((lvar? t1) → (Just (extend-subrule t1 t2 subrule))) 94 | ((lvar? t2) → (Just (extend-subrule t2 t1 subrule))) 95 | ;; just work for String value to pass the type checker case lvar is String type. 96 | ;; should create a new data type to support number list or more value types. 97 | ((∧ (> (len t1) 1) (> (len t2) 1)) → (match (unify [(head t1)] [(head t2)] subrule) 98 | ((Just s) → (unify (tail t1) (tail t2) s)) 99 | (Nothing → (Just subrule)))) 100 | (else → Nothing)))) 101 | 102 | (asserteq (unify va vb empty-subrule) 103 | (Just [("_.a" . "_.b")])) 104 | 105 | (asserteq (do Maybe 106 | (rule ← (unify va vb empty-subrule)) 107 | (unify va "1" rule)) 108 | (Just [("_.b" . "1") ("_.a" . "_.b")])) 109 | 110 | (asserteq (do Maybe 111 | (rule1 ← (unify va vb empty-subrule)) 112 | (rule2 ← (unify va "1" rule1)) 113 | (return (lookup-subrule vb rule2))) 114 | (Just "1")) 115 | 116 | (ƒ eqo [t1 t2] 117 | (λ s → (match (unify t1 t2 s) 118 | ((Just r) → (succeed r)) 119 | (Nothing → (fail s))))) 120 | 121 | (ƒ membero [var list] 122 | (match list 123 | ([] → fail) 124 | (h :: t → (disj* [(eqo var h) 125 | (membero var t)])))) 126 | 127 | (ƒ conso [a b list] 128 | (eqo (a :: b) list)) 129 | 130 | (ƒ run [g] (g empty-subrule)) 131 | 132 | (asserteq (run (membero "3" ["1" "2" "3"])) [[]]) 133 | (asserteq (run (membero "33" ["1" "2" "3"])) []) 134 | (asserteq (run (membero va ["1" "2" "3"])) [[("_.a" . "1")] [("_.a" . "2")] [("_.a" . "3")]]) 135 | (asserteq (run (conj* [(membero va ["1" "2" "3"]) 136 | (membero va ["2" "3" "4"])])) 137 | [[("_.a" . "2")] [("_.a" . "3")]]) 138 | 139 | (asserteq (run (conso '1' "2" va)) [[("_.a" . "12")]]) 140 | (asserteq (run (conso '1' va "12")) [[("_.a" . "2")]]) 141 | -------------------------------------------------------------------------------- /src/Ntha/Runtime/Value.hs: -------------------------------------------------------------------------------- 1 | module Ntha.Runtime.Value where 2 | 3 | import Ntha.Core.Ast 4 | import Prelude hiding (lookup) 5 | 6 | import Data.List (intercalate) 7 | import qualified Data.Map as M 8 | 9 | 10 | type ValueEnv = M.Map EName Value 11 | type ParentScope = ValueScope 12 | 13 | data ValueScope = ValueScope (Maybe ParentScope) ValueEnv 14 | 15 | createEmptyScope :: ValueScope 16 | createEmptyScope = ValueScope Nothing M.empty 17 | 18 | createScopeWithParent :: ParentScope -> ValueScope 19 | createScopeWithParent parent = ValueScope (Just parent) M.empty 20 | 21 | createScope :: ParentScope -> ValueEnv -> ValueScope 22 | createScope parent env = ValueScope (Just parent) env 23 | 24 | insert :: EName -> Value -> ValueScope -> ValueScope 25 | insert name t (ValueScope parent env) = ValueScope parent (M.insert name t env) 26 | 27 | lookup :: EName -> ValueScope -> Maybe Value 28 | lookup name (ValueScope parent env) = case M.lookup name env of 29 | Just t -> Just t 30 | Nothing -> case parent of 31 | Just p -> lookup name p 32 | Nothing -> Nothing 33 | 34 | -- create a child type scope of current parent type scope 35 | -- just to mock immutable scope, will remove later 36 | child :: ParentScope -> ValueScope 37 | child = createScopeWithParent 38 | 39 | instance Show ValueScope where 40 | show (ValueScope parent env) = (show . M.toList) env ++ case parent of 41 | Just p -> " -> " ++ show p 42 | Nothing -> " -| " 43 | 44 | type Tag = String 45 | type FreeVal = Value 46 | 47 | data Value = VNum Int 48 | | VChar Char 49 | | VBool Bool 50 | | VTuple [Value] 51 | | VRecord (M.Map EField Value) 52 | | VUnit 53 | | Adt Tag [Value] 54 | | Fn (Value -> ValueScope -> Value) -- or closure 55 | | FnApArgs (M.Map String Value) 56 | | DestrFnApArgs [PatVal] FreeVal 57 | | TConArgs [Value] Tag 58 | 59 | data PatVal = PatVal Pattern Value 60 | deriving (Eq, Show, Ord) 61 | 62 | nil :: Value 63 | nil = Adt "Nil" [] 64 | 65 | cons :: Value -> Value -> Value 66 | cons h t = Adt "Cons" [h, t] 67 | 68 | makeList :: [Value] -> Value 69 | makeList res = case res of 70 | [] -> nil 71 | x:xs -> cons x $ makeList xs 72 | 73 | getElements :: Value -> [Value] 74 | getElements l = case l of 75 | Adt "Cons" [h, t] -> h : (getElements t) 76 | _ -> [] 77 | 78 | reverseList :: Value -> Value 79 | reverseList l = makeList . reverse . getElements $ l 80 | 81 | strV :: String -> Value 82 | strV s = makeList $ map (VChar) s 83 | 84 | desugerStrV :: Value -> String 85 | desugerStrV (Adt _ values) = case values of 86 | [] -> "" 87 | _ -> intercalate "" (map desugerStrV values) 88 | desugerStrV v = show v 89 | 90 | -- binary operator 91 | binFn :: (Value -> Value -> Value) -> Value 92 | binFn f = Fn (\arg1 _ -> Fn (\arg2 _ -> f arg1 arg2)) 93 | 94 | isString :: Value -> Bool 95 | isString v = case v of 96 | Adt "Cons" [h, _] -> case h of 97 | VChar _ -> True 98 | _ -> False 99 | _ -> False 100 | 101 | stringOfAdt :: Tag -> [Value] -> String 102 | stringOfAdt tag values = case tag of 103 | "Cons" -> 104 | case (head values) of 105 | VChar _ -> "\"" ++ intercalate "" (map show (getElements (Adt tag values))) ++ "\"" 106 | _ -> "[" ++ intercalate ", " (map (\v -> case v of 107 | Adt "Nil" [] -> "[]" 108 | _ -> show v) (getElements (Adt tag values))) ++ "]" 109 | "Nil" -> "[]" 110 | _ -> tag ++ case values of 111 | []-> "" 112 | _ -> " " ++ intercalate " | " (map show values) 113 | 114 | stringOfPairs :: M.Map String Value -> String 115 | stringOfPairs pairs = "{" ++ intercalate "," (M.elems $ M.mapWithKey (\f v -> f ++ " : " ++ show v) pairs) ++ "}" 116 | 117 | instance Show Value where 118 | show (VNum i) = show i 119 | show (VChar c) = [c] 120 | show (VBool b) = show b 121 | show (VTuple values) = "(" ++ intercalate "," (map show values) ++ ")" 122 | show (VRecord pairs) = stringOfPairs pairs 123 | show VUnit = "⊥" 124 | show (Adt tag values) = stringOfAdt tag values 125 | show (Fn _) = "" 126 | show (FnApArgs pairs) = "FnApArgs(" ++ stringOfPairs pairs ++ ")" 127 | show (DestrFnApArgs pats val) = "DestrFnApArgs(" ++ intercalate ", " (map show pats) ++ " * " ++ show val ++ ")" 128 | show (TConArgs values tag) = "TConArgs(" ++ stringOfAdt tag values ++ ")" 129 | 130 | instance Eq Value where 131 | VNum int1 == VNum int2 = int1 == int2 132 | VChar char1 == VChar char2 = char1 == char2 133 | VBool bool1 == VBool bool2 = bool1 == bool2 134 | VTuple values1 == VTuple values2 = values1 == values2 135 | VRecord pairs1 == VRecord pairs2 = pairs1 == pairs2 136 | VUnit == VUnit = True 137 | Adt tag1 values1 == Adt tag2 values2 = tag1 == tag2 && values1 == values2 138 | FnApArgs pairs1 == FnApArgs pairs2 = pairs1 == pairs2 139 | DestrFnApArgs vals1 val1 == DestrFnApArgs vals2 val2 = vals1 == vals2 && val1 == val2 140 | TConArgs vals1 tag1 == TConArgs vals2 tag2 = vals1 == vals2 && tag1 == tag2 141 | _ == _ = False 142 | 143 | instance Ord Value where 144 | VNum int1 <= VNum int2 = int1 <= int2 145 | VChar char1 <= VChar char2 = char1 <= char2 146 | VBool bool1 <= VBool bool2 = bool1 <= bool2 147 | VTuple values1 <= VTuple values2 = values1 <= values2 148 | VRecord pairs1 <= VRecord pairs2 = pairs1 <= pairs2 149 | VUnit <= VUnit = True 150 | Adt tag1 values1 <= Adt tag2 values2 = tag1 <= tag2 && values1 <= values2 151 | FnApArgs pairs1 <= FnApArgs pairs2 = pairs1 <= pairs2 152 | DestrFnApArgs vals1 val1 <= DestrFnApArgs vals2 val2 = vals1 <= vals2 && val1 <= val2 153 | TConArgs vals1 tag1 <= TConArgs vals2 tag2 = vals1 <= vals2 && tag1 <= tag2 154 | _ <= _ = False 155 | -------------------------------------------------------------------------------- /src/Ntha/Type/Refined.hs: -------------------------------------------------------------------------------- 1 | module Ntha.Type.Refined where 2 | 3 | import Ntha.Core.Ast 4 | import Ntha.Type.Type 5 | import Ntha.Type.TypeScope 6 | import Ntha.Z3.Assertion 7 | import Ntha.Z3.Class 8 | import Ntha.Z3.Context 9 | import Ntha.Z3.Logic 10 | 11 | import Z3.Monad 12 | import Prelude hiding (lookup) 13 | import Control.Monad (mapM_) 14 | import Control.Monad.IO.Class (liftIO) 15 | 16 | genPred :: Term -> Z3Pred 17 | genPred term = case term of 18 | TmLT t1 t2 -> PAssert $ Less t1 t2 19 | TmGT t1 t2 -> PAssert $ Greater t1 t2 20 | TmLE t1 t2 -> PAssert $ LessE t1 t2 21 | TmGE t1 t2 -> PAssert $ GreaterE t1 t2 22 | TmEqual t1 t2 -> PAssert $ Equal t1 t2 23 | TmAnd t1 t2 -> PConj (genPred t1) (genPred t2) 24 | TmOr t1 t2 -> PDisj (genPred t1) (genPred t2) 25 | TmNot t -> PNeg (genPred t) 26 | _ -> error $ "not support term: " ++ show term 27 | 28 | replaceRtnTerm :: String -> Term -> Term -> Term 29 | replaceRtnTerm rtnName rtnTerm predTerm = case predTerm of 30 | TmVar n -> if n == rtnName then rtnTerm else predTerm 31 | TmNum _ -> predTerm 32 | TmLT t1 t2 -> TmLT (replaceRtnTerm' t1) (replaceRtnTerm' t2) 33 | TmGT t1 t2 -> TmGT (replaceRtnTerm' t1) (replaceRtnTerm' t2) 34 | TmLE t1 t2 -> TmLE (replaceRtnTerm' t1) (replaceRtnTerm' t2) 35 | TmGE t1 t2 -> TmGE (replaceRtnTerm' t1) (replaceRtnTerm' t2) 36 | TmSub t1 t2 -> TmSub (replaceRtnTerm' t1) (replaceRtnTerm' t2) 37 | TmAdd t1 t2 -> TmAdd (replaceRtnTerm' t1) (replaceRtnTerm' t2) 38 | TmMul t1 t2 -> TmMul (replaceRtnTerm' t1) (replaceRtnTerm' t2) 39 | TmDiv t1 t2 -> TmDiv (replaceRtnTerm' t1) (replaceRtnTerm' t2) 40 | TmEqual t1 t2 -> TmEqual (replaceRtnTerm' t1) (replaceRtnTerm' t2) 41 | TmAnd t1 t2 -> TmAnd (replaceRtnTerm' t1) (replaceRtnTerm' t2) 42 | TmOr t1 t2 -> TmOr (replaceRtnTerm' t1) (replaceRtnTerm' t2) 43 | TmNot t -> TmNot (replaceRtnTerm' t) 44 | TmIf t1 t2 t3 -> TmIf (replaceRtnTerm' t1) (replaceRtnTerm' t2) (replaceRtnTerm' t3) 45 | where replaceRtnTerm' = replaceRtnTerm rtnName rtnTerm 46 | 47 | genRtnPred :: String -> Term -> Term -> Z3Pred 48 | -- use neg to find counterexamples 49 | genRtnPred rtnName rtnTerm = PNeg . genPred . (replaceRtnTerm rtnName rtnTerm) 50 | 51 | convertProg' :: Expr -> Term 52 | convertProg' expr = case expr of 53 | ENum n -> TmNum n 54 | EVar name -> TmVar name 55 | EApp fn arg -> 56 | case fn of 57 | EApp (EVar op) arg' -> opConstruct argTerm' argTerm 58 | where argTerm' = convertProg' arg' 59 | argTerm = convertProg' arg 60 | opConstruct = 61 | case op of 62 | "+" -> TmAdd 63 | "-" -> TmSub 64 | "*" -> TmMul 65 | "/" -> TmDiv 66 | "<" -> TmLT 67 | ">" -> TmGT 68 | "≤" -> TmLE 69 | "≥" -> TmGE 70 | "=" -> TmEqual 71 | "∧" -> TmAnd 72 | "∨" -> TmOr 73 | _ -> error $ "not support op: " ++ op 74 | EVar op -> case op of 75 | "¬" -> let argTerm = convertProg' arg 76 | in TmNot argTerm 77 | _ -> error $ "not support op: " ++ op 78 | _ -> error $ "not support fn: " ++ show fn 79 | EIf cond (thenInstruction:[]) (elseInstruction:[]) -> TmIf condTerm thenTerm elseTerm 80 | where condTerm = convertProg' cond 81 | thenTerm = convertProg' thenInstruction 82 | elseTerm = convertProg' elseInstruction 83 | _ -> error $ "not support expr: " ++ show expr 84 | 85 | convertProg :: Expr -> TypeScope -> IO Z3Pred 86 | convertProg expr scope = case expr of 87 | -- only support exists and exists2 for now 88 | EDestructLetBinding main args (instruction:[]) -> do 89 | let name = case main of 90 | IdPattern n -> n ++ "-sig" 91 | _ -> "" 92 | let typeSig = lookup name scope 93 | let argNames = map (\pat -> case pat of 94 | IdPattern n -> n 95 | _ -> show pat) 96 | args 97 | case typeSig of 98 | Just (TSig ta) -> do 99 | let terms = extractTerm ta 100 | let predNames = getPredNames ta 101 | case predNames of 102 | -- (¬ ⊥) always satisfied 103 | [] -> return PFalse 104 | _ -> case (argNames, terms) of 105 | ([n], [rtnTerm']) -> 106 | return $ PExists n RTInt $ genRtnPred' rtnTerm' 107 | ([n1, n2], [rtnTerm']) -> 108 | return $ PExists2 n1 n2 RTInt $ genRtnPred' rtnTerm' 109 | ([n], [argTerm, rtnTerm']) -> 110 | return $ PExists n RTInt $ PConj (genPred argTerm) $ genRtnPred' rtnTerm' 111 | ([n1, n2], [argTerm1, argTerm2, rtnTerm']) -> 112 | return $ PExists2 n1 n2 RTInt $ PConj (PConj (genPred argTerm1) $ genPred argTerm2) $ genRtnPred' rtnTerm' 113 | _ -> error $ "not support args: " ++ show argNames ++ " and terms: " ++ show terms 114 | where rtnName = last predNames 115 | rtnTerm = convertProg' instruction 116 | genRtnPred' :: Term -> Z3Pred 117 | genRtnPred' = genRtnPred rtnName rtnTerm 118 | -- (¬ ⊥) always satisfied 119 | _ -> return PFalse 120 | EProgram (instruction:_) -> convertProg instruction scope 121 | _ -> error $ "not support expr: " ++ show expr 122 | 123 | checkPre :: Z3Pred -> Z3SMT () (Result, Maybe Model) 124 | checkPre pre = local $ do 125 | ast <- encode pre 126 | local (assert ast >> getModel) 127 | 128 | checker :: Expr -> TypeScope -> IO () 129 | checker expr scope = case expr of 130 | EDestructLetBinding _ _ _ -> do 131 | progPred <- convertProg expr scope 132 | -- trade off 133 | let adts = [("", [("", [("", RTInt)])])] 134 | ret <- runSMT adts () $ do 135 | (r, _mm) <- checkPre progPred 136 | case r of 137 | Unsat -> do 138 | core <- getUnsatCore 139 | liftIO $ sequence_ (map print core) 140 | return r 141 | other -> return other 142 | if ret == Right Unsat 143 | then return () 144 | else error "refined type check failed" 145 | EProgram instructions -> mapM_ (\instr -> checker instr scope) instructions 146 | _ -> return () 147 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Ntha Programming Language 2 | 3 | [![Build Status](https://travis-ci.org/zjhmale/Ntha.svg?branch=master)](https://travis-ci.org/zjhmale/Ntha) 4 | [![zjhmale](https://img.shields.io/badge/author-%40zjhmale-blue.svg)](https://github.com/zjhmale) 5 | [![Haskell](https://img.shields.io/badge/language-haskell-red.svg)](https://en.wikipedia.org/wiki/Haskell_(programming_language)) 6 | [![Hackage](https://img.shields.io/hackage/v/ntha.svg)](https://hackage.haskell.org/package/ntha) 7 | [![Hackage-Deps](https://img.shields.io/hackage-deps/v/idrigen.svg)](https://hackage.haskell.org/package/ntha) 8 | 9 | a tiny statically typed functional programming language. 10 | 11 | ## Installation 12 | 13 | * brew install z3 14 | * cabal install ntha 15 | 16 | ## Features 17 | 18 | * Global type inference with optional type annotations. 19 | * Lisp flavored syntax with Haskell like semantic inside. 20 | * Support basic types: Integer, Character, String, Boolean, Tuple, List and Record. 21 | * Support unicode keywords. 22 | * Support destructuring. 23 | * ADTs and pattern matching. 24 | * Haskell like type signature for type checking. 25 | * Refined types (still in early stage, just support basic arithmetic operations and propositinal logic, [here is some examples](https://github.com/zjhmale/Ntha/blob/master/examples/misc.ntha#L188-L195)), based on [z3-encoding](https://github.com/izgzhen/z3-encoding/tree/1d794c10db716ac9308e49bf4f5a115e14212f31) 26 | * Module system (still in early stage, lack of namespace control). 27 | * Support pattern matching on function parameters. 28 | * Lambdas and curried function by default. 29 | * Global and Local let binding. 30 | * Recursive functions. 31 | * If-then-else / Cond control flow. 32 | * Type alias. 33 | * Do notation. 34 | * Begin block. 35 | 36 | ## Future Works 37 | 38 | * Atoms (need to handle mutable state in evaluation procedure, reference to the [implementation of Clea Programming Language](https://github.com/zjhmale/Clea/blob/master/src/Prologue.hs#L191-211)). 39 | * error propagation (try / catch). 40 | * Lazyness. 41 | * JIT backend. 42 | * Type-classes (desuger to Records). 43 | * Rank-N types ([a naive implementation of First-Class Polymorphism](https://github.com/zjhmale/HMF/tree/master/src/FCP)). 44 | * λπ 45 | * Fully type checked lisp like macros (comply with the internal design of Template Haskell). 46 | * TCO. 47 | 48 | ## Screenshot 49 | 50 | ![cleantha](http://i.imgur.com/i1BrztC.gif) 51 | 52 | ## Example 53 | 54 | ```Clojure 55 | (type Name String) 56 | (type Env [(Name . Expr)]) 57 | 58 | (data Op Add Sub Mul Div Less Iff) 59 | 60 | (data Expr 61 | (Num Number) 62 | (Bool Boolean) 63 | (Var Name) 64 | (If Expr Expr Expr) 65 | (Let [Char] Expr Expr) 66 | (LetRec Name Expr Expr) 67 | (Lambda Name Expr) 68 | (Closure Expr Env) 69 | (App Expr Expr) 70 | (Binop Op (Expr . Expr))) 71 | 72 | (let op-map {:add + 73 | :sub - 74 | :mul * 75 | :div / 76 | :less < 77 | :iff =}) 78 | 79 | (arith-eval : (α → (β → Z)) → ((α × β) → (Maybe Expr))) 80 | (ƒ arith-eval [fn (v1 . v2)] 81 | (Just (Num (fn v1 v2)))) 82 | 83 | (logic-eval : (α → (β → B)) → ((α × β) → (Maybe Expr))) 84 | (ƒ logic-eval [fn (v1 . v2)] 85 | (Just (Bool (fn v1 v2)))) 86 | 87 | (let eval-op 88 | (λ op v1 v2 ⇒ 89 | (match (v1 . v2) 90 | (((Just (Num v1)) . (Just (Num v2))) ⇒ 91 | (match op 92 | (Add ⇒ (arith-eval (:add op-map) (v1 . v2))) 93 | (Sub ⇒ (arith-eval (:sub op-map) (v1 . v2))) 94 | (Mul ⇒ (arith-eval (:mul op-map) (v1 . v2))) 95 | (Div ⇒ (arith-eval (:div op-map) (v1 . v2))) 96 | (Less ⇒ (logic-eval (:less op-map) (v1 . v2))) 97 | (Iff ⇒ (logic-eval (:iff op-map) (v1 . v2))))) 98 | (_ ⇒ Nothing)))) 99 | 100 | (eval : [(S × Expr)] → (Expr → (Maybe Expr))) 101 | (ƒ eval [env expr] 102 | (match expr 103 | ((Num _) ⇒ (Just expr)) 104 | ((Bool _) → (Just expr)) 105 | ((Var x) ⇒ (do Maybe 106 | (val ← (lookup x env)) 107 | (return val))) 108 | ((If condition consequent alternative) → 109 | (match (eval env condition) 110 | ((Just (Bool true)) → (eval env consequent)) 111 | ((Just (Bool false)) → (eval env alternative)) 112 | (_ → (error "condition should be evaluated to a boolean value")))) 113 | ((Lambda _ _) → (Just (Closure expr env))) 114 | ((App fn arg) → (let [fnv (eval env fn)] 115 | (match fnv 116 | ((Just (Closure (Lambda x e) innerenv)) → 117 | (do Maybe 118 | (argv ← (eval env arg)) 119 | (eval ((x . argv) :: innerenv) e))) 120 | (_ → (error "should apply arg to a function"))))) 121 | ((Let x e1 in-e2) ⇒ (do Maybe 122 | (v ← (eval env e1)) 123 | (eval ((x . v) :: env) in-e2))) 124 | ;; use fix point combinator to approach "Turing-complete" 125 | ((LetRec x e1 in-e2) → (eval env (Let "Y" (Lambda "h" (App (Lambda "f" (App (Var "f") (Var "f"))) 126 | (Lambda "f" (App (Var "h") 127 | (Lambda "n" (App (App (Var "f") (Var "f")) 128 | (Var "n"))))))) 129 | (Let x (App (Var "Y") (Lambda x e1)) 130 | in-e2)))) 131 | ((Binop op (e1 . e2)) => (let [v1 (eval env e1) 132 | v2 (eval env e2)] 133 | (eval-op op v1 v2))))) 134 | 135 | (begin 136 | (print "start") 137 | (let result (match (eval [] (LetRec "fact" (Lambda "n" (If (Binop Less ((Var "n") . (Num 2))) 138 | (Num 1) 139 | (Binop Mul ((Var "n") . (App (Var "fact") 140 | (Binop Sub ((Var "n") . (Num 1)))))))) 141 | (App (Var "fact") (Num 5)))) 142 | ((Just (Num num)) ⇒ (print (int2str num))) 143 | (Nothing ⇒ (error "oops")))) 144 | (print result) 145 | (print "finish")) 146 | ``` 147 | 148 | ## License 149 | 150 | Copyright © 2016 zjhmale 151 | 152 | Distributed under the [![license BSD](https://img.shields.io/badge/license-BSD-orange.svg)](https://en.wikipedia.org/wiki/BSD_licenses) 153 | -------------------------------------------------------------------------------- /examples/symbolic_computation.ntha: -------------------------------------------------------------------------------- 1 | ;; example1 2 | 3 | (data Ast 4 | (Num Number) 5 | (Add Ast Ast) 6 | (Sub Ast Ast) 7 | (Mul Ast Ast) 8 | (Div Ast Ast)) 9 | 10 | (ƒ eval [n] 11 | (match n 12 | ((Num a) ⇒ a) 13 | ((Add a b) ⇒ (+ (eval a) (eval b))) 14 | ((Sub a b) ⇒ (- (eval a) (eval b))) 15 | ((Mul a b) ⇒ (* (eval a) (eval b))) 16 | ((Div a b) ⇒ (/ (eval a) (eval b))))) 17 | 18 | (let sym (Mul (Add (Num 4) (Num 3)) (Sub (Num 4) (Num 1)))) 19 | 20 | (let result (eval sym)) 21 | 22 | ;; example2 23 | 24 | (data Oper Add Sub) 25 | (data Expr 26 | (Num Number) 27 | (App Oper Expr Expr)) 28 | 29 | (let a (App Add (Num 5) (Num 6))) 30 | 31 | (ƒ eval [e] 32 | (match e 33 | ((Num n) ⇒ n) 34 | ((App o e1 e2) ⇒ 35 | (match o 36 | (Add ⇒ (+ (eval e1) (eval e2))) 37 | (Sub ⇒ (- (eval e1) (eval e2))))))) 38 | 39 | (let av (eval a)) 40 | 41 | (ƒ eval [e] 42 | (match e 43 | ((Num n) ⇒ n) 44 | ((App Add e1 e2) ⇒ (+ (eval e1) (eval e2))) 45 | ((App Sub e1 e2) ⇒ (- (eval e1) (eval e2))))) 46 | 47 | (let av (eval a)) 48 | 49 | (ƒ simplify [e] 50 | (match e 51 | ((App Add (Num n) e2) ⇒ (if (= n 0) e2 e)))) 52 | 53 | (let a (App Add (Num 0) (Num 6))) 54 | (let b (simplify a)) 55 | 56 | ;; example3 57 | 58 | 59 | (type Name String) 60 | (type Env [(Name . Expr)]) 61 | 62 | (data Op Add Sub Mul Div Less Iff) 63 | 64 | (data Expr 65 | (Num Number) 66 | (Bool Boolean) 67 | (Var Name) 68 | (If Expr Expr Expr) 69 | (Let [Char] Expr Expr) 70 | (LetRec Name Expr Expr) 71 | (Lambda Name Expr) 72 | (Closure Expr Env) 73 | (App Expr Expr) 74 | (Binop Op (Expr . Expr))) 75 | 76 | (let op-map {:add + 77 | :sub - 78 | :mul * 79 | :div / 80 | :less < 81 | :iff =}) 82 | 83 | (arith-eval : (α → (β → Z)) → ((α × β) → (Maybe Expr))) 84 | (ƒ arith-eval [fn (v1 . v2)] 85 | (Just (Num (fn v1 v2)))) 86 | 87 | (logic-eval : (α → (β → B)) → ((α × β) → (Maybe Expr))) 88 | (ƒ logic-eval [fn (v1 . v2)] 89 | (Just (Bool (fn v1 v2)))) 90 | 91 | (let eval-op 92 | (λ op v1 v2 ⇒ 93 | (match (v1 . v2) 94 | (((Just (Num v1)) . (Just (Num v2))) ⇒ 95 | (match op 96 | (Add ⇒ (arith-eval (:add op-map) (v1 . v2))) 97 | (Sub ⇒ (arith-eval (:sub op-map) (v1 . v2))) 98 | (Mul ⇒ (arith-eval (:mul op-map) (v1 . v2))) 99 | (Div ⇒ (arith-eval (:div op-map) (v1 . v2))) 100 | (Less ⇒ (logic-eval (:less op-map) (v1 . v2))) 101 | (Iff ⇒ (logic-eval (:iff op-map) (v1 . v2))))) 102 | (_ ⇒ Nothing)))) 103 | 104 | (eval : [([C] × Expr)] → (Expr → (Maybe Expr))) 105 | (ƒ eval [env expr] 106 | (match expr 107 | ((Num _) ⇒ (Just expr)) 108 | ((Bool _) → (Just expr)) 109 | ((Var x) ⇒ (do Maybe 110 | (val ← (lookup x env)) 111 | (return val))) 112 | ((If condition consequent alternative) → 113 | (match (eval env condition) 114 | ((Just (Bool true)) → (eval env consequent)) 115 | ((Just (Bool false)) → (eval env alternative)) 116 | (_ → (error "condition should be evaluated to a boolean value")))) 117 | ((Lambda _ _) → (Just (Closure expr env))) 118 | ((App fn arg) → (let [fnv (eval env fn)] 119 | (match fnv 120 | ((Just (Closure (Lambda x e) innerenv)) → 121 | (do Maybe 122 | (argv ← (eval env arg)) 123 | (eval ((x . argv) :: innerenv) e))) 124 | (_ → (error "should apply arg to a function"))))) 125 | ((Let x e1 in-e2) ⇒ (do Maybe 126 | (v ← (eval env e1)) 127 | (eval ((x . v) :: env) in-e2))) 128 | ((LetRec x e1 in-e2) → (do Maybe 129 | (fn <- (eval env (Let "Y" (Lambda "h" (App (Lambda "f" (App (Var "f") (Var "f"))) (Lambda "f" (App (Var "h") (Lambda "n" (App (App (Var "f") (Var "f")) (Var "n"))))))) 130 | (App (Var "Y") (Lambda "fact" e1))))) 131 | (eval (("fact" . fn) :: env) in-e2))) 132 | ;;((LetRec x e1 in-e2) → (eval env (Let "Y" (Lambda "h" (App (Lambda "f" (App (Var "f") (Var "f"))) (Lambda "f" (App (Var "h") (Lambda "n" (App (App (Var "f") (Var "f")) (Var "n"))))))) 133 | ;; (Let x (App (Var "Y") (Lambda x e1)) 134 | ;; in-e2)))) 135 | ((Binop op (e1 . e2)) => (let [v1 (eval env e1) 136 | v2 (eval env e2)] 137 | (eval-op op v1 v2))))) 138 | 139 | (match (eval [] (Let "x" (Num 2) (Let "f" (Lambda "y" (Binop Mul ((Var "x") . (Var "y")))) (App (Var "f") (Num 3))))) 140 | ((Just (Num num)) ⇒ (print (int2str num))) 141 | (Nothing ⇒ (error "oops"))) 142 | 143 | (eval [] (Binop Add ((Num 1) . (Num 2)))) 144 | (eval [] (Binop Mul ((Num 2) . (Num 3)))) 145 | (eval [] (Binop Mul ((Num 2) . (Binop Add ((Num 3) . (Num 4)))))) 146 | (eval [] (Binop Mul ((Binop Add ((Num 1) . (Num 2))) . (Binop Add ((Num 3) . (Num 4)))))) 147 | (eval [] (App (Lambda "x" (Binop Mul ((Num 2) . (Var "x")))) (Num 3))) 148 | (eval [] (Let "x" (Num 1) (Binop Add ((Var "x") . (Var "x"))))) 149 | (eval [] (Let "x" (Num 2) (Let "f" (Lambda "y" (Binop Mul ((Var "x") . (Var "y")))) (App (Var "f") (Num 3))))) 150 | (eval [] (Let "x" (Num 2) (Let "f" (Lambda "y" (Binop Mul ((Var "x") . (Var "y")))) (Let "x" (Num 4) (App (Var "f") (Num 3)))))) 151 | (eval [] (If (Binop Less ((Num 3) . (Num 6))) (Num 3) (Num 6))) 152 | 153 | (eval [] (Let "Y" (Lambda "h" (App (Lambda "f" (App (Var "f") (Var "f"))) (Lambda "f" (App (Var "h") (Lambda "n" (App (App (Var "f") (Var "f")) (Var "n"))))))) 154 | (Let "fact" (App (Var "Y") (Lambda "g" (Lambda "n" (If (Binop Less ((Var "n") . (Num 2))) (Num 1) (Binop Mul ((Var "n") . (App (Var "g") (Binop Sub ((Var "n") . (Num 1)))))))))) 155 | (App (Var "fact") (Num 5))))) 156 | 157 | (match (eval [] (Let "Y" (Lambda "h" (App (Lambda "f" (App (Var "f") (Var "f"))) (Lambda "f" (App (Var "h") (Lambda "n" (App (App (Var "f") (Var "f")) (Var "n"))))))) 158 | (Let "fact" (App (Var "Y") (Lambda "fact" (Lambda "n" (If (Binop Less ((Var "n") . (Num 2))) (Num 1) (Binop Mul ((Var "n") . (App (Var "fact") (Binop Sub ((Var "n") . (Num 1)))))))))) 159 | (App (Var "fact") (Num 5))))) 160 | ((Just (Num num)) ⇒ (print (int2str num))) 161 | (Nothing ⇒ (error "oops"))) 162 | 163 | (begin 164 | (print "start") 165 | (let result (match (eval [] (LetRec "fact" (Lambda "n" (If (Binop Less ((Var "n") . (Num 2))) (Num 1) (Binop Mul ((Var "n") . (App (Var "fact") (Binop Sub ((Var "n") . (Num 1)))))))) (App (Var "fact") (Num 5)))) 166 | ((Just (Num num)) ⇒ (int2str num)) 167 | (Nothing ⇒ (error "oops")))) 168 | (print result) 169 | (print "finish")) 170 | -------------------------------------------------------------------------------- /src/Ntha/Z3/Class.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Type classes and built-in implementation for primitive Haskell types 3 | -- 4 | 5 | module Ntha.Z3.Class ( 6 | -- ** Types whose values are encodable to Z3 internal AST 7 | Z3Encoded(..), 8 | -- ** Types representable as Z3 Sort 9 | -- XXX: Unsound now 10 | -- XXX: Too flexible, can be used to encode Type ADT 11 | Z3Sorted(..), 12 | -- ** Type proxy helper, used with Z3Sorted 13 | Z3Sort(..), 14 | -- ** Types with reserved value for Z3 encoding use 15 | -- XXX: Magic value for built-in types 16 | Z3Reserved(..), 17 | -- ** Monad which can be instantiated into a concrete context 18 | SMT(..) 19 | ) where 20 | 21 | import Ntha.Z3.Logic 22 | import Z3.Monad 23 | 24 | import Control.Monad.Except 25 | 26 | import qualified Data.Map as M 27 | import qualified Data.Set as S 28 | 29 | data Z3Sort a = Z3Sort 30 | 31 | class Z3Encoded a where 32 | encode :: SMT m e => a -> m e AST 33 | 34 | -- | XXX: Unsound 35 | class Z3Sorted a where 36 | -- | Map a value to Sort, the value should be a type-level thing 37 | sort :: SMT m e => a -> m e Sort 38 | sort _ = sortPhantom (Z3Sort :: Z3Sort a) 39 | 40 | -- | Map a Haskell type to Sort 41 | sortPhantom :: SMT m e => Z3Sort a -> m e Sort 42 | sortPhantom _ = smtError "sort error" 43 | 44 | class Z3Encoded a => Z3Reserved a where 45 | def :: a 46 | 47 | class (MonadError String (m e), MonadZ3 (m e)) => SMT m e where 48 | -- | Globally unique id 49 | genFreshId :: m e Int 50 | 51 | -- | Given data type declarations, extra field, and the SMT monad, return the fallible result in IO monad 52 | runSMT :: Z3Sorted ty => [(String, [(String, [(String, ty)])])] -> e -> m e a -> IO (Either String a) 53 | 54 | -- | Binding a variable String name to two things: an de Brujin idx as Z3 AST generated by mkBound and binder's Sort 55 | bindQualified :: String -> AST -> Sort -> m e () 56 | 57 | -- | Get the above AST 58 | -- FIXME: The context management need extra -- we need to make sure that old binding wouldn't be destoryed 59 | -- XXX: We shouldn't expose a Map here. A fallible query interface is better 60 | getQualifierCtx :: m e (M.Map String (AST, Sort)) 61 | 62 | -- | Get the preprocessed datatype context, a map from ADT's type name to its Z3 Sort 63 | -- XXX: We shouldn't expose a Map here. A fallible query interface is better 64 | getDataTypeCtx :: m e (M.Map String Sort) 65 | 66 | -- | Get extra 67 | getExtra :: m e e 68 | 69 | -- | Set extra 70 | modifyExtra :: (e -> e) -> m e () 71 | 72 | -- | User don't have to import throwError 73 | smtError :: String -> m e a 74 | smtError = throwError 75 | 76 | instance Z3Reserved Int where 77 | def = -1 -- XXX: Magic number 78 | 79 | instance Z3Sorted Int where 80 | sortPhantom _ = mkIntSort 81 | 82 | instance Z3Encoded Int where 83 | encode i = mkIntSort >>= mkInt i 84 | 85 | instance Z3Reserved Double where 86 | def = -1.0 -- XXX: Magic number 87 | 88 | instance Z3Sorted Double where 89 | sortPhantom _ = mkRealSort 90 | 91 | instance Z3Encoded Double where 92 | encode = mkRealNum 93 | 94 | instance Z3Reserved Bool where 95 | def = False -- XXX: Magic number 96 | 97 | instance Z3Sorted Bool where 98 | sortPhantom _ = mkBoolSort 99 | 100 | instance Z3Encoded Bool where 101 | encode = mkBool 102 | 103 | -- The basic idea: 104 | -- For each (k, v), assert in Z3 that if we select k from array we will get 105 | -- the same value v 106 | -- HACK: to set a default value for rest fields (or else we always get the last asserted value 107 | -- as default, which is certainly not complying to finite map's definition), thus the 108 | -- user should guarantee that he/she will never never think this value as a vaid one, 109 | -- if not, he/she might get "a valid value mapped to a invalid key" semantics 110 | instance (Z3Sorted k, Z3Encoded k, Z3Sorted v, Z3Reserved v) => Z3Encoded (M.Map k v) where 111 | encode m = do 112 | fid <- genFreshId 113 | arrSort <- sort m 114 | arr <- mkFreshConst ("map" ++ "_" ++ show fid) arrSort 115 | mapM_ (\(k, v) -> do 116 | kast <- encode k 117 | vast <- encode v 118 | sel <- mkSelect arr kast 119 | mkEq sel vast >>= assert) (M.toList m) 120 | arrValueDef <- mkArrayDefault arr 121 | vdef <- encode (def :: v) 122 | mkEq arrValueDef vdef >>= assert 123 | return arr 124 | 125 | instance (Z3Sorted k, Z3Sorted v) => Z3Sorted (M.Map k v) where 126 | sortPhantom _ = do 127 | sk <- sortPhantom (Z3Sort :: Z3Sort k) 128 | sv <- sortPhantom (Z3Sort :: Z3Sort v) 129 | mkArraySort sk sv 130 | 131 | -- Basic idea: 132 | -- Set v =def= Map v {0, 1} 133 | -- Thank god, this is much more sound 134 | instance (Z3Sorted v, Z3Encoded v) => Z3Encoded (S.Set v) where 135 | encode s = do 136 | setSort <- sort s 137 | fid <- genFreshId 138 | arr <- mkFreshConst ("set" ++ "_" ++ show fid) setSort 139 | mapM_ (\e -> do 140 | ast <- encode e 141 | sel <- mkSelect arr ast 142 | one <- (mkIntSort >>= mkInt 1) 143 | mkEq sel one >>= assert) (S.toList s) 144 | arrValueDef <- mkArrayDefault arr 145 | zero <- (mkIntSort >>= mkInt 0) 146 | mkEq zero arrValueDef >>= assert 147 | return arr 148 | 149 | instance Z3Sorted v => Z3Sorted (S.Set v) where 150 | sortPhantom _ = do 151 | sortElem <- sortPhantom (Z3Sort :: Z3Sort v) 152 | intSort <- mkIntSort 153 | mkArraySort sortElem intSort 154 | 155 | instance (Z3Sorted t, Z3Sorted ty, Z3Encoded a) => Z3Encoded (Pred t ty a) where 156 | encode PTrue = mkTrue 157 | encode PFalse = mkFalse 158 | encode (PConj p1 p2) = do 159 | a1 <- encode p1 160 | a2 <- encode p2 161 | mkAnd [a1, a2] 162 | 163 | encode (PDisj p1 p2) = do 164 | a1 <- encode p1 165 | a2 <- encode p2 166 | mkOr [a1, a2] 167 | 168 | encode (PXor p1 p2) = do 169 | a1 <- encode p1 170 | a2 <- encode p2 171 | mkXor a1 a2 172 | 173 | encode (PNeg p) = encode p >>= mkNot 174 | 175 | encode (PForAll x ty p) = do 176 | sym <- mkStringSymbol x 177 | xsort <- sort ty 178 | -- "0" is de brujin idx for current binder 179 | -- it is passed to Z3 which returns an intenal (idx :: AST) 180 | -- This (idx :: AST) will be used to replace the variable 181 | -- in the abstraction body when encountered, thus it is stored 182 | -- in context by bindQualified we provide 183 | -- XXX: we should save and restore qualifier context here 184 | idx <- mkBound 0 xsort 185 | local $ do 186 | bindQualified x idx xsort 187 | body <- encode p 188 | -- The first [] is [Pattern], which is not really useful here 189 | mkForall [] [sym] [xsort] body 190 | 191 | encode (PExists x ty p) = do 192 | sym <- mkStringSymbol x 193 | xsort <- sort ty 194 | idx <- mkBound 0 xsort 195 | local $ do 196 | bindQualified x idx xsort 197 | a <- encode p 198 | mkExists [] [sym] [xsort] a 199 | 200 | -- HACK 201 | encode (PExists2 x y ty p) = do 202 | sym1 <- mkStringSymbol x 203 | sym2 <- mkStringSymbol y 204 | xsort <- sort ty 205 | idx1 <- mkBound 0 xsort 206 | idx2 <- mkBound 1 xsort 207 | local $ do 208 | bindQualified x idx1 xsort 209 | bindQualified y idx2 xsort 210 | a <- encode p 211 | mkExists [] [sym1, sym2] [xsort, xsort] a 212 | 213 | encode (PImpli p1 p2) = do 214 | a1 <- encode p1 215 | a2 <- encode p2 216 | mkImplies a1 a2 217 | 218 | encode (PIff p1 p2) = do 219 | a1 <- encode p1 220 | a2 <- encode p2 221 | mkIff a1 a2 222 | 223 | encode (PAssert a) = encode a 224 | -------------------------------------------------------------------------------- /src/Ntha/Core/Ast.hs: -------------------------------------------------------------------------------- 1 | module Ntha.Core.Ast where 2 | 3 | import Ntha.Type.Type 4 | 5 | import Data.List (intercalate) 6 | import Data.Maybe (fromMaybe) 7 | import qualified Data.Map as M 8 | import qualified Text.PrettyPrint as PP 9 | 10 | type EName = String -- variable name 11 | type EPath = String 12 | type EField = String 13 | type EIndent = Int 14 | type TypeVariable = Type -- just for documentation 15 | 16 | data Expr = EVar EName 17 | | EAccessor Expr EField 18 | | ENum Int 19 | | EStr String 20 | | EChar Char 21 | | EBool Bool 22 | | EList [Expr] 23 | | ETuple [Expr] 24 | | ERecord (M.Map EField Expr) 25 | | EUnit 26 | | ELambda [Named] (Maybe Type) [Expr] 27 | | EApp Expr Expr 28 | | EIf Expr [Expr] [Expr] 29 | | EPatternMatching Expr [Case] 30 | | ELetBinding Pattern Expr [Expr] 31 | | EDestructLetBinding Pattern [Pattern] [Expr] 32 | | EDataDecl EName Type [TypeVariable] [TypeConstructor] 33 | | ETypeSig EName Type -- explicit type annotation 34 | | EImport EPath 35 | | EProgram [Expr] 36 | deriving (Eq, Ord) 37 | 38 | isImport :: Expr -> Bool 39 | isImport expr = case expr of 40 | EImport _ -> True 41 | _ -> False 42 | 43 | -- for do block desuger to bind 44 | data Bind = Bind EName Expr 45 | | Return Expr 46 | | Single Expr 47 | 48 | -- for cond desuger to if 49 | data Clause = Clause Expr Expr 50 | | Else Expr 51 | 52 | data TypeConstructor = TypeConstructor EName [Type] 53 | deriving (Eq, Ord) 54 | 55 | data Named = Named EName (Maybe Type) 56 | deriving (Eq, Ord) 57 | 58 | data Pattern = WildcardPattern 59 | | IdPattern EName 60 | | NumPattern Int 61 | | BoolPattern Bool 62 | | CharPattern Char 63 | | TuplePattern [Pattern] 64 | | TConPattern EName [Pattern] 65 | deriving (Eq, Ord) 66 | 67 | data Case = Case Pattern [Expr] 68 | deriving (Eq, Ord) 69 | 70 | -- temp structure for parser 71 | data EVConArg = EVCAVar EName 72 | | EVCAOper EName [EName] 73 | | EVCAList EVConArg 74 | | EVCATuple [EVConArg] 75 | deriving (Show, Eq, Ord) 76 | 77 | data EVConstructor = EVConstructor EName [EVConArg] 78 | deriving (Show, Eq, Ord) 79 | 80 | substName :: M.Map EName EName -> Expr -> Expr 81 | substName subrule (EVar name) = EVar $ fromMaybe name $ M.lookup name subrule 82 | substName subrule (EAccessor expr field) = EAccessor (substName subrule expr) field 83 | substName subrule (EList exprs) = EList $ map (substName subrule) exprs 84 | substName subrule (ETuple exprs) = ETuple $ map (substName subrule) exprs 85 | substName subrule (ERecord pairs) = ERecord $ M.map (substName subrule) pairs 86 | substName subrule (ELambda nameds t exprs) = ELambda newNames t newExprs 87 | where 88 | newNames = map (\(Named name t') -> Named (fromMaybe name $ M.lookup name subrule) t') nameds 89 | newExprs = map (substName subrule) exprs 90 | substName subrule (EApp fn arg) = EApp (substName subrule fn) (substName subrule arg) 91 | substName subrule (EIf cond thenInstrs elseInstrs) = EIf newCond newThenInstrs newElseInstrs 92 | where 93 | newCond = substName subrule cond 94 | newThenInstrs = map (substName subrule) thenInstrs 95 | newElseInstrs = map (substName subrule) elseInstrs 96 | substName subrule (EPatternMatching expr cases) = EPatternMatching newExpr newCases 97 | where 98 | newCases = map (\(Case pat exprs) -> Case pat (map (substName subrule) exprs)) cases 99 | newExpr = substName subrule expr 100 | substName subrule (ELetBinding pat expr exprs) = ELetBinding pat (substName subrule expr) $ map (substName subrule) exprs 101 | substName _ e = e 102 | 103 | tab :: EIndent -> String 104 | tab i = intercalate "" $ take i $ repeat "\t" 105 | 106 | stringOfNamed :: Named -> String 107 | stringOfNamed (Named name t) = name ++ case t of 108 | Just t' -> ":" ++ show t' 109 | Nothing -> "" 110 | 111 | stringofNameds :: [Named] -> String 112 | stringofNameds = unwords . (map stringOfNamed) 113 | 114 | stringOfExpr :: Expr -> String 115 | stringOfExpr e = case e of 116 | EApp fn arg -> "<" ++ show fn ++ ">(" ++ show arg ++ ")" 117 | ELambda params annoT body -> "λ" ++ stringofNameds params ++ b 118 | where b = (case annoT of 119 | Just annoT' -> " : " ++ show annoT' 120 | Nothing -> "") 121 | ++ " = \n" ++ intercalate "" (map (\instr -> "\t" ++ show instr ++ "\n") body) 122 | EIf cond thenInstrs elseInstrs -> "if " ++ show cond ++ " then \n" ++ th ++ "else \n" ++ el 123 | where stringOfInstrs instrs = intercalate "" $ map (\instr -> "\t" ++ show instr ++ "\n") instrs 124 | th = stringOfInstrs thenInstrs 125 | el = stringOfInstrs elseInstrs 126 | EProgram instrs -> intercalate "" $ map (\instr -> show instr ++ "\n") instrs 127 | _ -> reprOfExpr 0 e 128 | 129 | stringOfCase :: EIndent -> Case -> String 130 | stringOfCase i (Case pat outcomes) = "\n" ++ tab i ++ show pat ++ " ⇒ " ++ show outcomes 131 | 132 | stringOfCases :: EIndent -> [Case] -> String 133 | stringOfCases i cases = intercalate "" (map (stringOfCase i) cases) 134 | 135 | reprOfExpr :: EIndent -> Expr -> String 136 | reprOfExpr i e = case e of 137 | EVar n -> tab i ++ n 138 | EAccessor e' f -> tab i ++ reprOfExpr 0 e' ++ "." ++ f 139 | ENum v -> tab i ++ show v 140 | EStr v -> tab i ++ v 141 | EChar v -> tab i ++ [v] 142 | EBool v -> tab i ++ show v 143 | EUnit -> tab i ++ "()" 144 | EList es -> tab i ++ show es 145 | ETuple es -> "(" ++ intercalate "," (map (reprOfExpr 0) es) ++ ")" 146 | ERecord pairs -> "{" ++ intercalate "," (M.elems $ M.mapWithKey (\f v -> f ++ ": " ++ reprOfExpr 0 v) pairs) ++ "}" 147 | EApp _ _ -> tab i ++ show e 148 | ELambda params annoT body -> tab i ++ "λ" ++ stringofNameds params ++ b 149 | where b = (case annoT of 150 | Just annoT' -> " : " ++ show annoT' 151 | Nothing -> "") 152 | ++ " = \n" ++ intercalate "" (map (\instr -> "\t" ++ reprOfExpr (i + 1) instr ++ "\n") body) 153 | EIf cond thenInstrs elseInstrs -> tab i ++ "if " ++ show cond ++ " then \n" ++ th ++ tab i ++ "else \n" ++ el 154 | where stringOfInstrs instrs = intercalate "" $ map (\instr -> "\t" ++ reprOfExpr (i + 1) instr ++ "\n") instrs 155 | th = stringOfInstrs thenInstrs 156 | el = stringOfInstrs elseInstrs 157 | EPatternMatching input cases -> tab i ++ "match " ++ show input ++ stringOfCases i cases 158 | EDataDecl name _ tvars tcons -> tab i ++ "data " ++ name ++ " " ++ unwords (map show tvars) ++ " = " ++ cs 159 | where scons = (map (\(TypeConstructor name' types) -> 160 | name' ++ case types of 161 | [] -> "" 162 | _ -> " " ++ unwords (map show types)) tcons) 163 | cs = intercalate " | " scons 164 | EDestructLetBinding main args instrs -> tab i ++ "let " ++ show main ++ " " ++ unwords (map show args) ++ " = \n" ++ is 165 | where is = intercalate "" (map (\instr -> reprOfExpr (i + 1) instr ++ "\n") instrs) 166 | ELetBinding main def body -> tab i ++ "let " ++ show main ++ " " ++ show def ++ " in " ++ intercalate "\n" (map show body) 167 | ETypeSig name t -> tab i ++ "(" ++ name ++ " : " ++ show t ++ ")" 168 | EImport path -> "import " ++ path 169 | EProgram instrs -> intercalate "" $ map (\instr -> reprOfExpr i instr ++ "\n") instrs 170 | 171 | instance Show Expr where 172 | showsPrec _ x = shows $ PP.text $ stringOfExpr x 173 | 174 | instance Show Pattern where 175 | show WildcardPattern = "_" 176 | show (NumPattern val) = "pint→" ++ show val 177 | show (BoolPattern val) = "pbool→" ++ show val 178 | show (CharPattern val) = "pchar→" ++ show val 179 | show (IdPattern name) = "'" ++ name ++ "'" 180 | show (TuplePattern pattens) = "(" ++ intercalate "," (map show pattens) ++ ")" 181 | show (TConPattern name pattens) = name ++ " " ++ show pattens 182 | -------------------------------------------------------------------------------- /examples/type_infer.ntha: -------------------------------------------------------------------------------- 1 | (type Prim String) 2 | (type Binder Number) 3 | (type Name String) 4 | (type Fresh Binder) 5 | (type Context [(Name . Type)]) 6 | (type Subrule [(Binder . Type)]) 7 | 8 | (data Expr 9 | (EVar Binder) 10 | (ELam Binder Expr) 11 | (EApp Expr Expr) 12 | (ELet Binder Expr Expr)) 13 | 14 | (data Type 15 | (TPrim Prim) 16 | (TVar Binder) 17 | (Type :~> Type) 18 | (TPoly [Binder] Type)) 19 | 20 | (let intT (TPrim "int")) 21 | (let boolT (TPrim "bool")) 22 | 23 | (ƒ subst 24 | [s t] 25 | (match t 26 | ((TVar b) → (lookup! t b s)) 27 | ((t1 :~> t2) → ((subst s t1) :~> (subst s t2))) 28 | ((TPoly bs t') → (TPoly bs (subst (diff-map s bs) t'))) 29 | (_ → t))) 30 | 31 | (ƒ subst-ctx 32 | [s ctx] 33 | (map-map (subst s) ctx)) 34 | 35 | (ƒ compose 36 | [s2 s1] 37 | (union-map (map-map (subst s2) s1) s2)) 38 | 39 | (ƒ free-vars 40 | [t] 41 | (match t 42 | ((TVar b) → [b]) 43 | ((t1 :~> t2) → (nub (concat (free-vars t1) (free-vars t2)))) 44 | ((TPoly bs t') → (diff-list (free-vars t') bs)) 45 | (_ → []))) 46 | 47 | (ƒ occurs-in? 48 | [b t] 49 | (exists? b (free-vars t))) 50 | 51 | (unify : Type → (Type → [(Number × Type)])) 52 | (ƒ unify 53 | [t1 t2] 54 | (match (t1 . t2) 55 | (((TPrim _) . (TPrim _)) → []) 56 | (((TVar b) . t) → (if (occurs-in? b t) 57 | (error "infinite type found!") 58 | [(b . t)])) 59 | ((t . (TVar b)) → (unify t2 t1)) 60 | (((t1 :~> t2) . (t1' :~> t2')) → (let [s1 (unify t1 t1') 61 | s2 (unify (subst s1 t2) 62 | (subst s1 t2'))] 63 | (compose s2 s1))) 64 | ((_ . _) → (error "unification failed!")))) 65 | 66 | (let tvarA 0) 67 | (let tvarB 1) 68 | (let tvarC 2) 69 | (let tvarD 3) 70 | (let tvarE 4) 71 | (let tvarF 5) 72 | (let tvarG 6) 73 | 74 | (let mono1 ((TVar tvarA) :~> intT)) 75 | (let mono2 ((TVar tvarB) :~> (TVar tvarB))) 76 | (let mono3 ((TVar tvarA) :~> (TVar tvarB))) 77 | (let mono4 (((TVar tvarB) :~> (TVar tvarC)) :~> (TVar tvarC))) 78 | (let mono5 ((TVar tvarA) :~> (TVar tvarB))) 79 | (let mono6 ((TVar tvarC) :~> (TVar tvarA))) 80 | 81 | (asserteq (unify mono1 mono2) [(tvarB . (TPrim "int")) (tvarA . (TPrim "int"))]) 82 | (asserteq (unify mono3 mono4) [(tvarB . (TVar tvarC)) (tvarA . ((TVar tvarC) :~> (TVar tvarC)))]) 83 | (asserteq (unify mono5 mono6) [(tvarB . (TVar tvarC)) (tvarA . (TVar tvarC))]) 84 | 85 | (make-fresh : Number → ([α] → ([(α × Type)] × Number))) 86 | (ƒ make-fresh 87 | [fresh bs] 88 | (match bs 89 | ([] → ([] . fresh)) 90 | (h :: t → (match (make-fresh (inc fresh) t) 91 | ((s . fresh') → (((h . (TVar fresh)) :: s) . fresh')))))) 92 | 93 | (instantiate : Number → (Type → (Type × Number))) 94 | (ƒ instantiate 95 | [fresh t] 96 | (match t 97 | ((TPoly bs t') → (let [(subrule . fresh') (make-fresh fresh bs)] 98 | ((subst subrule t') . fresh'))) 99 | (_ → (t . fresh)))) 100 | 101 | (generalize : [(Number × α)] → (Type → Type)) 102 | (ƒ generalize 103 | [ctx t] 104 | (let [frees (nub (diff-list (free-vars t) (map fst ctx)))] 105 | (TPoly frees t))) 106 | 107 | (w' : Number → ([(Number × Type)] → (Expr → (([(Number × Type)] × Type) × Number)))) 108 | (ƒ w' 109 | [fresh ctx expr] 110 | (match expr 111 | ((EVar b) → (match (lookup b ctx) 112 | (Nothing → (error "ubound variable")) 113 | ((Just t) → (let [(t' . fresh') (instantiate fresh t)] 114 | (([] . t') . fresh'))))) 115 | ((EApp fn arg) → (match (w' (inc fresh) ctx fn) 116 | (((s1 . t1) . fresh1) → 117 | (match (w' fresh1 (subst-ctx s1 ctx) arg) 118 | (((s2 . t2) . fresh2) → 119 | (let [b (TVar fresh) 120 | s3 (unify (subst s2 t1) (t2 :~> b))] 121 | (((compose s3 (compose s2 s1)) . (subst s3 b)) . fresh2))))))) 122 | ((ELam name body) → (let [b (TVar fresh)] 123 | (match (w' (inc fresh) (union-map [(name . b)] ctx) body) 124 | (((s . t) . fresh') → ((s . ((subst s b) :~> t)) . fresh'))))) 125 | ((ELet name def body) → (match (w' fresh ctx def) 126 | (((s1 . t1) . fresh1) → 127 | (let [ctx' (subst-ctx s1 ctx) 128 | g (generalize ctx' t1) 129 | ctx'' (union-map [(name . g)] ctx')] 130 | (match (w' fresh1 ctx'' body) 131 | (((s2 . t2) . fresh2) → (((compose s2 s1) . t2) . fresh2))))))))) 132 | 133 | (ƒ w 134 | [assumps expr] 135 | (match (w' 0 assumps expr) 136 | (((_ . t) . _) → (generalize [] t)))) 137 | 138 | (let assumptions [(0 . intT) ;; 139 | (1 . intT) ;; one 140 | (2 . boolT) ;; true 141 | (3 . boolT) ;; false 142 | (4 . (boolT :~> boolT)) ;; not 143 | (5 . (intT :~> (intT :~> intT))) ;; add 144 | (6 . (TPoly [tvarA] ((TVar tvarA) :~> (TVar tvarA)))) ;; id 145 | (7 . (TPoly [tvarA] ((TVar tvarA) :~> ((TVar tvarA) :~> boolT)))) ;; eq 146 | (8 . (TPoly [tvarA tvarB tvarC] (((TVar tvarB) :~> (TVar tvarC)) :~> (((TVar tvarA) :~> (TVar tvarB)) :~> ((TVar tvarA) :~> (TVar tvarC)))))) ;; compose 147 | (9 . (TPoly [tvarA] ((TVar tvarA) :~> ((TVar tvarA) :~> (TVar tvarA))))) ;; choose 148 | (10 . (TPoly [tvarA tvarB tvarC] (((TVar tvarA) :~> ((TVar tvarB) :~> (TVar tvarC))) :~> ((TVar tvarB) :~> ((TVar tvarA) :~> (TVar tvarC)))))) ;; flip 149 | ]) 150 | 151 | (ƒ infer 152 | [expr] 153 | (w assumptions expr)) 154 | 155 | (asserteq (infer (EVar 6)) (TPoly [tvarA] ((TVar tvarA) :~> (TVar tvarA)))) 156 | (asserteq (infer (EApp (EVar 6) (EApp (EVar 6) (EVar 1)))) (TPoly [] intT)) 157 | (asserteq (infer (EApp (EApp (EVar 7) (EVar 3)) (EVar 2))) (TPoly [] boolT)) 158 | (asserteq (infer (EApp (EVar 8) (EVar 4))) (TPoly [tvarB] (((TVar tvarB) :~> boolT) :~> ((TVar tvarB) :~> boolT)))) 159 | (asserteq (infer (EApp (EApp (EVar 8) (EVar 4)) (EApp (EVar 7) (EVar 1)))) (TPoly [] (intT :~> boolT))) 160 | (asserteq (infer (EApp (EVar 8) (EApp (EVar 5) (EVar 1)))) (TPoly [tvarB] (((TVar tvarB) :~> intT) :~> ((TVar tvarB) :~> intT)))) 161 | (asserteq (infer (EApp (EApp (EApp (EVar 8) (EVar 7)) (EVar 5)) (EVar 1))) (TPoly [] ((intT :~> intT) :~> boolT))) 162 | 163 | (let evarX 100) 164 | (let evarY 200) 165 | (let evarA 300) 166 | (let evarB 400) 167 | (let evarC 500) 168 | 169 | (asserteq (infer (ELam evarA 170 | (ELam evarB 171 | (ELet evarA 172 | (EApp (EVar evarA) 173 | (EVar evarB)) 174 | (ELam evarA 175 | (EApp (EVar evarB) 176 | (EVar evarA))))))) 177 | (TPoly [tvarC tvarD tvarE] ((((TVar tvarD) :~> (TVar tvarE)) :~> (TVar tvarC)) :~> (((TVar tvarD) :~> (TVar tvarE)) :~> ((TVar tvarD) :~> (TVar tvarE)))))) 178 | 179 | (asserteq (infer (ELam evarA 180 | (ELet evarX 181 | (ELam evarB 182 | (ELet evarY 183 | (ELam evarC (EApp (EVar evarA) (EVar 0))) 184 | (EApp (EVar evarY) (EVar 1)))) 185 | (EApp (EVar evarX) (EVar 1))))) 186 | (TPoly [tvarF] ((intT :~> (TVar tvarF)) :~> (TVar tvarF)))) 187 | 188 | (asserteq (infer (EApp (EApp (EVar 9) 189 | (ELam evarA 190 | (ELam evarB 191 | (EVar evarA)))) 192 | (ELam evarA 193 | (ELam evarB 194 | (EVar evarB))))) 195 | (TPoly [tvarG] ((TVar tvarG) :~> ((TVar tvarG) :~> (TVar tvarG))))) 196 | 197 | (asserteq (infer (EApp (EVar 8) (EVar 8))) 198 | (TPoly [tvarB tvarF tvarE tvarG] (((TVar tvarB) :~> ((TVar tvarF) :~> (TVar tvarG))) :~> ((TVar tvarB) :~> (((TVar tvarE) :~> (TVar tvarF)) :~> ((TVar tvarE) :~> (TVar tvarG))))))) 199 | 200 | ;; flip id 201 | (asserteq (infer (EApp (EVar 10) (EVar 6))) (TPoly [tvarC tvarD] ((TVar tvarC) :~> (((TVar tvarC) :~> (TVar tvarD)) :~> (TVar tvarD))))) 202 | -------------------------------------------------------------------------------- /src/Ntha/Type/Type.hs: -------------------------------------------------------------------------------- 1 | module Ntha.Type.Type where 2 | 3 | import Ntha.State 4 | import Ntha.Z3.Assertion 5 | import Ntha.Z3.Class 6 | import Ntha.Z3.Logic 7 | 8 | import Z3.Monad 9 | import Control.Monad (foldM, liftM) 10 | import System.IO.Unsafe (unsafePerformIO) 11 | import Data.IORef 12 | import Data.List (intercalate) 13 | import Data.Maybe (fromMaybe) 14 | import qualified Data.Map as M 15 | import qualified Data.Set as S 16 | import qualified Text.PrettyPrint as PP 17 | 18 | type Id = Int 19 | type TName = String 20 | type TField = String 21 | type Types = [Type] 22 | type TInstance = Maybe Type 23 | type Z3Pred = Pred Term RType Assertion 24 | 25 | data Type = TVar Id (IORef TInstance) TName -- type variable 26 | | TOper TName Types -- type operator 27 | | TRecord (M.Map TField Type) 28 | | TCon TName Types Type 29 | | TSig Type 30 | | TRefined String Type Term 31 | 32 | -- extract normal type from refined type for type inference 33 | extractType :: Type -> Type 34 | extractType t = case t of 35 | -- just support arrow type for now 36 | TOper "→" args -> TOper "→" (map extractType args) 37 | TRefined _ t' _ -> t' 38 | _ -> t 39 | 40 | extractTerm :: Type -> [Term] 41 | extractTerm t = case t of 42 | TOper "→" args -> args >>= extractTerm 43 | TRefined _ _ tm -> [tm] 44 | _ -> [] 45 | 46 | getPredNames :: Type -> [String] 47 | getPredNames t = case t of 48 | TOper "→" args -> args >>= getPredNames 49 | TRefined n _ _ -> [n] 50 | _ -> [] 51 | 52 | intT :: Type 53 | intT = TOper "Number" [] 54 | 55 | boolT :: Type 56 | boolT = TOper "Boolean" [] 57 | 58 | charT :: Type 59 | charT = TOper "Char" [] 60 | 61 | listT :: Type -> Type -- list type is not polymorphism 62 | listT t = TOper "List" [t] 63 | 64 | productT :: Types -> Type -- tuple type, product type is a name from Algebraic Data type 65 | productT ts = TOper "*" ts 66 | 67 | arrowT :: Type -> Type -> Type -- function type with single param 68 | arrowT fromType toType = TOper "→" $ [fromType, toType] 69 | 70 | functionT :: Types -> Type -> Type 71 | functionT paramsT rtnT = foldr (\paramT resT -> arrowT paramT resT) rtnT paramsT 72 | 73 | strT :: Type 74 | strT = listT charT 75 | 76 | unitT :: Type 77 | unitT = TOper "()" [] 78 | 79 | prune :: Type -> Infer Type 80 | prune t = case t of 81 | TVar _ inst _ -> do 82 | instV <- readIORef inst 83 | case instV of 84 | Just inst' -> do 85 | newInstance <- prune inst' 86 | writeIORef inst $ Just newInstance 87 | return newInstance 88 | Nothing -> return t 89 | _ -> return t 90 | 91 | stringOfType :: M.Map TName TName -> Type -> Infer String 92 | stringOfType subrule (TVar _ inst name) = do 93 | instV <- readIORef inst 94 | case instV of 95 | Just inst' -> stringOfType subrule inst' 96 | Nothing -> return $ fromMaybe "α" $ M.lookup name subrule 97 | stringOfType subrule (TOper name args) = case name of 98 | "*" -> do 99 | argsStr <- (intercalate " * ") <$> mapM (stringOfType subrule) args 100 | return $ "(" ++ argsStr ++ ")" 101 | "List" -> do 102 | argStr <- stringOfType subrule $ args!!0 103 | return $ "[" ++ argStr ++ "]" 104 | "→" -> do 105 | argT <- prune $ args!!0 106 | rtnT <- prune $ args!!1 107 | argStr <- stringOfType subrule argT 108 | rtnStr <- stringOfType subrule rtnT 109 | let adjust t s = case t of 110 | TOper "→" _ -> "(" ++ s ++ ")" 111 | _ -> s 112 | let argStr' = adjust argT argStr 113 | let rtnStr' = adjust rtnT rtnStr 114 | return $ argStr' ++ " → " ++ rtnStr' 115 | _ -> if (length args) == 0 116 | then return name 117 | else do 118 | argsStr <- unwords <$> mapM (stringOfType subrule) args 119 | return $ "(" ++ name ++ " " ++ argsStr ++ ")" 120 | stringOfType subrule (TRecord pairs) = do 121 | pairsStr <- (intercalate ", ") <$> (mapM (\(k, v) -> ((k ++ ": ") ++) <$> stringOfType subrule v) $ M.toList pairs) 122 | return $ "{" ++ pairsStr ++ "}" 123 | stringOfType subrule (TCon name types dataType) = do 124 | dataTypeStr <- stringOfType subrule dataType 125 | case types of 126 | [] -> return dataTypeStr 127 | _ -> do 128 | typesStr <- (intercalate ", ") <$> mapM (stringOfType subrule) types 129 | return $ "(" ++ name ++ " " ++ typesStr ++ " ⇒ " ++ dataTypeStr ++ ")" 130 | stringOfType subrule (TSig t) = liftM ("typesig: " ++) $ stringOfType subrule t 131 | stringOfType subrule (TRefined _ t _) = liftM ("refined: " ++) $ stringOfType subrule t 132 | 133 | getFreeVars :: Type -> Infer (S.Set TName) 134 | getFreeVars (TVar _ inst name) = do 135 | instV <- readIORef inst 136 | case instV of 137 | Just inst' -> getFreeVars inst' 138 | Nothing -> return $ S.singleton name 139 | getFreeVars (TOper _ args) = 140 | foldM (\acc arg -> do 141 | freeVars <- getFreeVars arg 142 | return $ S.union freeVars acc) 143 | S.empty args 144 | getFreeVars (TRecord pairs) = 145 | foldM (\acc (_, v) -> do 146 | freeVars <- getFreeVars v 147 | return $ S.union freeVars acc) 148 | S.empty $ M.toList pairs 149 | getFreeVars (TCon _ types dataType) = 150 | foldM (\acc t -> do 151 | freeVars <- getFreeVars t 152 | return $ S.union freeVars acc) 153 | S.empty $ types ++ [dataType] 154 | getFreeVars (TSig t) = getFreeVars t 155 | getFreeVars (TRefined _ t _) = getFreeVars t 156 | 157 | {-# NOINLINE normalize #-} 158 | normalize :: Type -> String 159 | normalize t = unsafePerformIO $ do 160 | freeVars <- getFreeVars t 161 | let subrule = M.map (\c -> [c]) $ M.fromList $ zip (S.toList freeVars) ['α'..'ω'] 162 | stringOfType subrule t 163 | 164 | instance Show Type where 165 | showsPrec _ x = shows $ PP.text $ normalize x 166 | 167 | instance Eq Type where 168 | TVar id1 inst1 vname1 == TVar id2 inst2 vname2 = id1 == id2 && instV1 == instV2 && vname1 == vname2 where 169 | instV1 = readState inst1 170 | instV2 = readState inst2 171 | TOper name1 args1 == TOper name2 args2 = name1 == name2 && args1 == args2 172 | TRecord pairs1 == TRecord pairs2 = pairs1 == pairs2 173 | TCon name1 types1 dataType1 == TCon name2 types2 dataType2 = name1 == name2 && types1 == types2 && dataType1 == dataType2 174 | TSig t1 == TSig t2 = t1 == t2 175 | TRefined x1 t1 tm1 == TRefined x2 t2 tm2 = x1 == x2 && t1 == t2 && tm1 == tm2 176 | _ == _ = False 177 | 178 | instance Ord Type where 179 | TVar id1 inst1 vname1 <= TVar id2 inst2 vname2 = id1 <= id2 && instV1 <= instV2 && vname1 <= vname2 where 180 | instV1 = readState inst1 181 | instV2 = readState inst2 182 | TOper name1 args1 <= TOper name2 args2 = name1 <= name2 && args1 <= args2 183 | TRecord pairs1 <= TRecord pairs2 = pairs1 <= pairs2 184 | TCon name1 types1 dataType1 <= TCon name2 types2 dataType2 = name1 <= name2 && types1 <= types2 && dataType1 <= dataType2 185 | TSig t1 <= TSig t2 = t1 <= t2 186 | TRefined x1 t1 tm1 <= TRefined x2 t2 tm2 = x1 <= x2 && t1 <= t2 && tm1 <= tm2 187 | _ <= _ = False 188 | 189 | makeVariable :: Infer Type 190 | makeVariable = do 191 | i <- nextId 192 | name <- nextUniqueName 193 | instRef <- newIORef Nothing 194 | return $ TVar i instRef name 195 | 196 | -- for refined type 197 | 198 | data Term = TmVar String 199 | | TmNum Int 200 | | TmLT Term Term 201 | | TmGT Term Term 202 | | TmLE Term Term 203 | | TmGE Term Term 204 | | TmSub Term Term 205 | | TmAdd Term Term 206 | | TmMul Term Term 207 | | TmDiv Term Term 208 | | TmEqual Term Term 209 | | TmAnd Term Term 210 | | TmOr Term Term 211 | | TmNot Term 212 | | TmIf Term Term Term 213 | 214 | deriving instance Eq Term 215 | deriving instance Ord Term 216 | deriving instance Show Term 217 | 218 | -- currently just support integer 219 | data RType = RTInt 220 | 221 | deriving instance Eq RType 222 | deriving instance Ord RType 223 | 224 | instance Z3Encoded Term where 225 | encode (TmVar x) = do 226 | ctx <- getQualifierCtx 227 | case M.lookup x ctx of 228 | Just (idx, _) -> return idx 229 | Nothing -> smtError $ "Can't find variable " ++ x 230 | encode (TmNum n) = mkIntSort >>= mkInt n 231 | encode (TmLT t1 t2) = encode (Less t1 t2) 232 | encode (TmGT t1 t2) = encode (Greater t1 t2) 233 | encode (TmLE t1 t2) = encode (LessE t1 t2) 234 | encode (TmGE t1 t2) = encode (GreaterE t1 t2) 235 | encode (TmAdd t1 t2) = do 236 | a1 <- encode t1 237 | a2 <- encode t2 238 | mkAdd [a1, a2] 239 | encode (TmSub t1 t2) = do 240 | a1 <- encode t1 241 | a2 <- encode t2 242 | mkSub [a1, a2] 243 | encode (TmMul t1 t2) = do 244 | a1 <- encode t1 245 | a2 <- encode t2 246 | mkMul [a1, a2] 247 | encode (TmDiv t1 t2) = do 248 | a1 <- encode t1 249 | a2 <- encode t2 250 | mkDiv a1 a2 251 | encode (TmEqual t1 t2) = do 252 | a1 <- encode t1 253 | a2 <- encode t2 254 | mkEq a1 a2 255 | encode (TmAnd t1 t2) = do 256 | a1 <- encode t1 257 | a2 <- encode t2 258 | mkAnd [a1, a2] 259 | encode (TmOr t1 t2) = do 260 | a1 <- encode t1 261 | a2 <- encode t2 262 | mkOr [a1, a2] 263 | encode (TmNot t) = encode t >>= mkNot 264 | encode (TmIf p c a) = do 265 | a1 <- encode p 266 | a2 <- encode c 267 | a3 <- encode a 268 | mkIte a1 a2 a3 269 | 270 | instance Z3Sorted Term where 271 | sort (TmVar x) = do 272 | ctx <- getQualifierCtx 273 | case M.lookup x ctx of 274 | Just (_, s) -> return s 275 | Nothing -> smtError $ "Can't find variable " ++ x 276 | sort (TmNum _) = mkIntSort 277 | sort (TmLT _ _) = mkBoolSort 278 | sort (TmGT _ _) = mkBoolSort 279 | sort (TmLE _ _) = mkBoolSort 280 | sort (TmGE _ _) = mkBoolSort 281 | sort (TmAdd _ _) = mkIntSort 282 | sort (TmSub _ _) = mkIntSort 283 | sort (TmMul _ _) = mkIntSort 284 | sort (TmDiv _ _) = mkIntSort 285 | sort (TmEqual _ _) = mkBoolSort 286 | sort (TmAnd _ _) = mkBoolSort 287 | sort (TmOr _ _) = mkBoolSort 288 | sort (TmNot _) = mkBoolSort 289 | sort (TmIf _ c _) = sort c 290 | 291 | instance Z3Sorted RType where 292 | sort RTInt = mkIntSort 293 | -------------------------------------------------------------------------------- /src/Ntha/Type/Infer.hs: -------------------------------------------------------------------------------- 1 | module Ntha.Type.Infer where 2 | 3 | import Ntha.Core.Ast 4 | import Ntha.State 5 | import Ntha.Type.Type 6 | import Ntha.Type.TypeScope 7 | 8 | import Prelude hiding (lookup) 9 | import Control.Monad (foldM, forM_, when, zipWithM_) 10 | import Control.Monad.Loops (anyM) 11 | import Data.IORef 12 | import qualified Data.Map as M 13 | import qualified Data.Set as S 14 | 15 | type NonGeneric = (S.Set Type) 16 | 17 | occursInType :: Type -> Type -> Infer Bool 18 | occursInType v t = do 19 | tP <- prune t 20 | case tP of 21 | TOper _ ts -> occursIn v ts 22 | v' -> return $ v == v' 23 | 24 | occursIn :: Type -> [Type] -> Infer Bool 25 | occursIn t = anyM (occursInType t) 26 | 27 | isGeneric :: Type -> NonGeneric -> Infer Bool 28 | isGeneric t nonGeneric = not <$> (occursIn t $ S.toList nonGeneric) 29 | 30 | fresh :: Type -> NonGeneric -> Infer Type 31 | fresh t nonGeneric = do 32 | mappings <- newIORef M.empty -- A mapping of TypeVariables to TypeVariables 33 | let freshrec ty = (\tyP -> case tyP of 34 | TVar _ _ _ -> do 35 | isG <- isGeneric tyP nonGeneric 36 | if isG 37 | then do 38 | m <- readIORef mappings 39 | case M.lookup tyP m of 40 | Just tVar -> return tVar 41 | Nothing -> do 42 | newVar <- makeVariable 43 | modifyIORef mappings $ M.insert tyP newVar 44 | return newVar 45 | else return tyP 46 | TOper name types -> do 47 | newTypes <- mapM freshrec types 48 | return $ TOper name newTypes 49 | TCon name types dataType -> do 50 | newTypes <- mapM freshrec types 51 | newDataType <- freshrec dataType 52 | return $ TCon name newTypes newDataType 53 | TRecord valueTypes -> do 54 | newValueTypes <- foldM (\acc (k, v) -> do 55 | fv <- freshrec v 56 | return $ M.insert k fv acc) 57 | M.empty $ M.toList valueTypes 58 | return $ TRecord newValueTypes 59 | _ -> return tyP) 60 | =<< prune ty 61 | freshrec t 62 | 63 | getType :: TName -> TypeScope -> NonGeneric -> Infer Type 64 | getType name scope nonGeneric = case lookup name scope of 65 | Just var -> fresh var nonGeneric 66 | Nothing -> error $ "Undefined symbol " ++ name 67 | 68 | adjustType :: Type -> Type 69 | adjustType t = case t of 70 | TCon _ types dataType -> functionT types dataType 71 | _ -> t 72 | 73 | unify :: Type -> Type -> Infer () 74 | unify t1 t2 = do 75 | t1P <- prune t1 76 | t2P <- prune t2 77 | let t1PA = adjustType t1P 78 | let t2PA = adjustType t2P 79 | case (t1PA, t2PA) of 80 | (a@(TVar _ inst _), b) -> when (a /= b) $ do 81 | isOccurs <- occursInType a b 82 | when isOccurs $ error "Recusive unification" 83 | writeIORef inst $ Just b 84 | (a@(TOper _ _), b@(TVar _ _ _)) -> unify b a 85 | (a@(TOper name1 types1), b@(TOper name2 types2)) -> 86 | if name1 /= name2 || (length types1) /= (length types2) 87 | then error $ "Type mismatch " ++ show a ++ " ≠ " ++ show b 88 | else zipWithM_ unify types1 types2 89 | (a@(TRecord types1), b@(TRecord types2)) -> mapM_ (\(k, t2') -> do 90 | case M.lookup k types1 of 91 | Just t1' -> unify t2' t1' 92 | Nothing -> error $ "Cannot unify, no field " ++ k ++ " " ++ show a ++ ", " ++ show b) 93 | $ M.toList types2 94 | _ -> error $ "Can not unify " ++ show t1 ++ ", " ++ show t2 95 | 96 | visitPattern :: Pattern -> TypeScope -> NonGeneric -> Infer (TypeScope, NonGeneric, Type) 97 | visitPattern pattern scope nonGeneric = case pattern of 98 | WildcardPattern -> do 99 | resT <- makeVariable 100 | return (scope, nonGeneric, resT) 101 | IdPattern name -> do 102 | resT <- makeVariable 103 | return (insert name resT scope, S.insert resT nonGeneric, resT) 104 | NumPattern _ -> return (scope, nonGeneric, intT) 105 | BoolPattern _ -> return (scope, nonGeneric, boolT) 106 | CharPattern _ -> return (scope, nonGeneric, charT) 107 | TuplePattern items -> do 108 | (itemTypes, newScope, newNonGeneric) <- foldM (\(types, env, nonGen) item -> do 109 | (newEnv, newNonGen, itemT) <- visitPattern item env nonGen 110 | return (types ++ [itemT], newEnv, newNonGen)) 111 | ([], scope, nonGeneric) items 112 | return (newScope, newNonGeneric, productT itemTypes) 113 | TConPattern name patterns -> do 114 | (patTypes, newScope, newNonGeneric) <- foldM (\(types, env, nonGen) pat -> do 115 | (newEnv, newNonGen, patT) <- visitPattern pat env nonGen 116 | return (types ++ [patT], newEnv, newNonGen)) 117 | ([], scope, nonGeneric) patterns 118 | case lookup name newScope of 119 | Nothing -> error $ "Unknow type constructor " ++ name 120 | Just tconT -> case tconT of 121 | TCon _ _ _ -> do 122 | (TCon _ types dataType) <- fresh tconT newNonGeneric 123 | if (length patterns) /= (length types) 124 | then error $ "Bad arity: case " 125 | ++ show pattern 126 | ++ " provided " 127 | ++ (show . length) patterns 128 | ++ " arguments whereas " 129 | ++ name 130 | ++ " takes " 131 | ++ (show . length) types 132 | else do 133 | zipWithM_ unify patTypes types 134 | return (newScope, newNonGeneric, dataType) 135 | _ -> error $ "Invalid type constructor " ++ name 136 | 137 | definePattern :: Pattern -> Type -> TypeScope -> Infer TypeScope 138 | definePattern pattern t scope = do 139 | tP <- prune t 140 | case pattern of 141 | IdPattern name -> return $ insert name tP scope 142 | TuplePattern items -> case tP of 143 | TOper _ types -> do 144 | newScope <- foldM (\env (pat, patT) -> do 145 | newEnv <- definePattern pat patT env 146 | return newEnv) 147 | scope $ zip items types 148 | return newScope 149 | _ -> error $ "Invalid type " ++ show tP ++ " for pattern " ++ show pattern 150 | TConPattern _ patterns -> case tP of 151 | -- t is always functionT for now so a little non-sense for this case. 152 | TCon _ types _ -> do 153 | newScope <- foldM (\env (pat, patT) -> do 154 | newEnv <- definePattern pat patT env 155 | return newEnv) 156 | scope $ zip patterns types 157 | return newScope 158 | TOper _ types -> do 159 | newScope <- foldM (\env (pat, patT) -> do 160 | newEnv <- definePattern pat patT env 161 | return newEnv) 162 | scope $ zip patterns types 163 | return newScope 164 | _ -> error $ "Invalid type " ++ show tP ++ " for pattern " ++ show pattern 165 | _ -> return scope 166 | 167 | analyze :: Expr -> TypeScope -> NonGeneric -> Infer (TypeScope, Type) 168 | analyze expr scope nonGeneric = case expr of 169 | ENum _ -> return (scope, intT) 170 | EBool _ -> return (scope, boolT) 171 | EChar _ -> return (scope, charT) 172 | EStr _ -> return (scope, strT) 173 | EUnit -> return (scope, unitT) 174 | EList exprs -> do 175 | valueT <- makeVariable 176 | -- type checking procedure, since types of elems in a list should be the same. 177 | forM_ exprs (\e -> do 178 | (_, eT) <- analyze e scope nonGeneric 179 | unify valueT eT) 180 | return (scope, listT valueT) 181 | ETuple exprs -> do 182 | types <- foldM (\types expr' -> do 183 | (_, ty) <- analyze expr' scope nonGeneric 184 | return $ types ++ [ty]) 185 | [] exprs 186 | return (scope, productT types) 187 | ERecord pairs -> do 188 | valueTypes <- foldM (\vts (k, v) -> do 189 | (_, t) <- analyze v scope nonGeneric 190 | return $ M.insert k t vts) 191 | M.empty $ M.toList pairs 192 | return (scope, TRecord valueTypes) 193 | EVar name -> (scope,) <$> getType name scope nonGeneric 194 | EApp fn arg -> do 195 | (_, fnT) <- analyze fn scope nonGeneric 196 | (_, argT) <- analyze arg scope nonGeneric 197 | rtnT <- makeVariable 198 | unify (functionT [argT] rtnT) fnT 199 | return (scope, rtnT) 200 | ELambda params annoT instructions -> do 201 | let newScope = child scope 202 | (paramTypes, newScope', newNonGeneric) <- 203 | foldM (\(types', env', nonGeneric') (Named name t) -> 204 | case t of 205 | Just t' -> return (types' ++ [t'], insert name t' env', S.insert t' nonGeneric') 206 | Nothing -> do 207 | t' <- makeVariable 208 | return (types' ++ [t'], insert name t' env', S.insert t' nonGeneric')) 209 | ([], newScope, nonGeneric) params 210 | rtnT <- foldM (\_ instr -> snd <$> analyze instr newScope' newNonGeneric) unitT instructions 211 | case annoT of 212 | Just annoT' -> unify rtnT annoT' -- type propagation from return type to param type 213 | Nothing -> return () 214 | -- use fresh just to make sure sequence of lambda abstractions with same type var name could work well e.g. 215 | -- ((λ(x: α) : α → x) 3) 216 | -- ((λ(x: α) : α → x) true) 217 | (scope,) <$> fresh (functionT paramTypes rtnT) nonGeneric 218 | EAccessor obj field -> do 219 | (_, objT) <- analyze obj scope nonGeneric 220 | fieldT <- makeVariable 221 | let desiredT = TRecord $ M.fromList [(field, fieldT)] 222 | unify objT desiredT 223 | return (scope, fieldT) 224 | EIf cond thenInstructions elseInstructions -> do 225 | (_, condT) <- analyze cond scope nonGeneric 226 | unify condT boolT 227 | (newScope, thenT) <- foldM (\(env, _) instr -> analyze instr env nonGeneric) 228 | (scope, unitT) thenInstructions 229 | (newScope', elseT) <- foldM (\(env, _) instr -> analyze instr env nonGeneric) 230 | (newScope, unitT) elseInstructions 231 | unify thenT elseT 232 | return (newScope', thenT) 233 | ELetBinding main def body -> do 234 | (scope', _) <- analyze (EDestructLetBinding main [] [def]) scope nonGeneric 235 | foldM (\(env, _) instr -> analyze instr env nonGeneric) (scope', unitT) body 236 | EDestructLetBinding main args instructions -> do 237 | let name = case main of 238 | IdPattern n -> n ++ "-sig" 239 | _ -> "" 240 | let typeSig = lookup name scope 241 | let newScope = child scope 242 | (newScope', newNonGeneric, letTV) <- visitPattern main newScope nonGeneric 243 | let newNonGeneric' = S.insert letTV newNonGeneric 244 | (argTypes, newScope'', newNonGeneric'') <- 245 | foldM (\(types, env, nonGen) arg -> do 246 | (newEnv, newNonGen, argT) <- visitPattern arg env nonGen 247 | return (types ++ [argT], newEnv, newNonGen)) 248 | ([], newScope', newNonGeneric') args 249 | rtnT <- foldM (\_ instr -> snd <$> analyze instr newScope'' newNonGeneric'') unitT instructions 250 | let letT = functionT argTypes rtnT 251 | newScope''' <- definePattern main letT newScope'' 252 | case typeSig of 253 | Just (TSig ta) -> do 254 | let ta' = extractType ta 255 | unify ta' letT 256 | _ -> return () 257 | return (newScope''', letT) 258 | EDataDecl _ t _ tconstructors -> do 259 | let newScope = foldl (\env (TypeConstructor conName conTypes) -> 260 | insert conName (TCon conName conTypes t) env) 261 | scope tconstructors 262 | return (newScope, t) 263 | EPatternMatching input cases -> do 264 | (_, inputT) <- analyze input scope nonGeneric 265 | resT <- makeVariable 266 | resT' <- foldM (\rt (Case pat outcomes) -> do 267 | let newScope = child scope 268 | (newScope', newNonGeneric, patT) <- visitPattern pat newScope nonGeneric 269 | -- make sure pattern type of each case is the same with input type 270 | unify patT inputT 271 | (_, caseT) <- foldM (\(env, _) outcome -> analyze outcome env newNonGeneric) 272 | (newScope', unitT) outcomes 273 | -- make sure return type of each case are the same 274 | unify caseT rt 275 | return rt) 276 | resT cases 277 | return (scope, resT') 278 | ETypeSig name t -> return (insert (name ++ "-sig") (TSig t) scope, unitT) 279 | EProgram instructions -> foldM (\(env, _) instr -> analyze instr env nonGeneric) (scope, unitT) instructions 280 | _ -> error $ "not support infer expr: " ++ show expr 281 | -------------------------------------------------------------------------------- /src/Ntha/Runtime/Eval.hs: -------------------------------------------------------------------------------- 1 | module Ntha.Runtime.Eval where 2 | 3 | import Ntha.Core.Ast 4 | import Ntha.Runtime.Value 5 | 6 | import Prelude hiding (lookup) 7 | import Data.Maybe (fromMaybe) 8 | import qualified Data.Map as M 9 | import qualified Data.Set as S 10 | 11 | type Exclude = S.Set EName 12 | 13 | evalFn :: Value -> Value -> ValueScope -> Value 14 | evalFn (Fn f) arg scope = f arg scope 15 | evalFn _ _ _ = VUnit 16 | 17 | chainingFn :: EName -> Value -> Value 18 | chainingFn argName next = 19 | Fn (\oarg _ -> 20 | Fn (\arg scope -> 21 | let margs = case oarg of 22 | FnApArgs pairs -> 23 | let v = fromMaybe VUnit $ M.lookup "***" pairs 24 | in FnApArgs $ M.insert "***" arg $ M.insert argName v pairs 25 | _ -> FnApArgs $ M.fromList [(argName, oarg), ("***", arg)] 26 | in evalFn next margs scope)) 27 | 28 | chaininLastFn :: EName -> [Expr] -> Value 29 | chaininLastFn argName body = 30 | Fn (\arg scope -> 31 | let scope' = case arg of 32 | FnApArgs pairs -> 33 | foldl (\env (k, v) -> insert k v env) 34 | scope 35 | (M.toList $ 36 | M.insert argName 37 | (fromMaybe VUnit $ M.lookup "***" pairs) pairs) 38 | _ -> insert argName arg scope 39 | in snd $ foldl (\(env, val) instr -> val `seq` eval instr env) (scope', VUnit) body) 40 | 41 | destrChainingFn :: Pattern -> Value -> Value 42 | destrChainingFn pat next = 43 | Fn (\oarg _ -> 44 | Fn (\arg scope -> 45 | let margs = case oarg of 46 | DestrFnApArgs args freeVal -> DestrFnApArgs (args ++ [PatVal pat freeVal]) arg 47 | _ -> DestrFnApArgs [PatVal pat oarg] arg 48 | in evalFn next margs scope)) 49 | 50 | destrChaininLastFn :: Pattern -> [Expr] -> Value 51 | destrChaininLastFn pat body = 52 | Fn (\arg scope -> 53 | let scope' = case arg of 54 | DestrFnApArgs args freeVal -> 55 | let s = foldl (\env (PatVal pat' val) -> 56 | define pat' val env) 57 | scope 58 | args 59 | in define pat freeVal s 60 | _ -> define pat arg scope 61 | in snd $ foldl (\(env, val) instr -> val `seq` eval instr env) (scope', VUnit) body) 62 | 63 | tConChainingFn :: Tag -> Value -> Value 64 | tConChainingFn tag next = 65 | Fn (\oarg _ -> 66 | Fn (\arg scope -> 67 | let targs = case oarg of 68 | TConArgs args tag' -> TConArgs (args ++ [arg]) tag' 69 | _ -> TConArgs [oarg, arg] tag 70 | in evalFn next targs scope)) 71 | 72 | tConChaininLastFn :: Tag -> Value 73 | tConChaininLastFn tag = 74 | Fn (\arg _ -> 75 | let args = case arg of 76 | TConArgs args' _ -> args' 77 | VUnit -> [] 78 | _ -> [arg] 79 | in Adt tag args) 80 | 81 | excludePatternBoundNames :: Pattern -> Exclude -> Exclude 82 | excludePatternBoundNames pat excluded = case pat of 83 | IdPattern name -> S.insert name excluded 84 | TuplePattern pats -> foldl (\exc p -> excludePatternBoundNames p exc) excluded pats 85 | TConPattern _ pats -> foldl (\exc p -> excludePatternBoundNames p exc) excluded pats 86 | _ -> excluded 87 | 88 | visit :: Expr -> ValueScope -> ValueEnv -> Exclude -> (ValueScope, ValueEnv, Exclude) 89 | visit expr scope capturedEnv excluded = case expr of 90 | EList values -> 91 | foldl (\(s, c, e) value -> visit value s c e) 92 | (scope, capturedEnv, excluded) values 93 | EIf cond thenInstrs elseInstrs -> (sco'', env'', exc'') where 94 | (sco, env, exc) = visit cond scope capturedEnv excluded 95 | (sco', env', exc') = foldl (\(s, c, e) value -> visit value s c e) 96 | (sco, env, exc) thenInstrs 97 | (sco'', env'', exc'') = foldl (\(s, c, e) value -> visit value s c e) 98 | (sco', env', exc') elseInstrs 99 | EVar name -> 100 | if name `notElem` excluded 101 | then let (scope', val) = eval expr scope 102 | in (scope', M.insert name val capturedEnv, excluded) 103 | else (scope, capturedEnv, excluded) 104 | EApp fn arg -> 105 | let (s, c, e) = visit fn scope capturedEnv excluded 106 | in visit arg s c e 107 | EDestructLetBinding main _ _ -> (scope, capturedEnv, excludePatternBoundNames main excluded) 108 | EPatternMatching input cases -> 109 | let (scope', capturedEnv', excluded') = visit input scope capturedEnv excluded 110 | in foldl (\(s, c, e) (Case pat outcomes) -> 111 | let e' = excludePatternBoundNames pat e 112 | in let (s', c', _) = foldl (\(sco, env, exc) instr -> visit instr sco env exc) 113 | (s, c, e') 114 | outcomes 115 | in (s', c', e)) 116 | (scope', capturedEnv', excluded') cases 117 | _ -> (scope, capturedEnv, excluded) 118 | 119 | envCapturingFnWrapper :: Value -> Expr -> ValueScope -> Value 120 | envCapturingFnWrapper fn expr scope = case expr of 121 | (ELambda params _ instrs) -> mkFn capturedEnv where 122 | excluded = foldl (\exc (Named name _) -> S.insert name exc) S.empty params 123 | capturedEnv = mkCapturedEnv excluded instrs 124 | (EDestructLetBinding (IdPattern name) args instrs) -> mkFn capturedEnv where 125 | excluded = foldl (\exc pat -> excludePatternBoundNames pat exc) (S.singleton name) args 126 | capturedEnv = mkCapturedEnv excluded instrs 127 | _ -> VUnit 128 | where mkCapturedEnv excluded instrs = 129 | let (_, capturedEnv, _) = foldl (\(s, c, e) instr -> visit instr s c e) 130 | (scope, M.empty, excluded) 131 | instrs 132 | in capturedEnv 133 | mkFn capturedEnv = 134 | Fn (\arg scope' -> 135 | let scope'' = foldl (\env (k, v) -> insert k v env) 136 | scope' $ M.toList capturedEnv 137 | in evalFn fn arg scope'') 138 | 139 | -- to predicate if a value is match specific pattern 140 | match :: Value -> Pattern -> ValueScope -> (ValueScope, Bool) 141 | match input pattern scope = case pattern of 142 | WildcardPattern -> (scope, True) 143 | IdPattern name -> (insert name input scope, True) 144 | NumPattern val -> (scope, input == (VNum val)) 145 | BoolPattern val -> (scope, input == (VBool val)) 146 | CharPattern val -> (scope, input == (VChar val)) 147 | TuplePattern pats -> case input of 148 | VTuple items -> if length items /= length pats 149 | then (scope, False) 150 | else isAllMatch items pats 151 | _ -> (scope, False) 152 | TConPattern name pats -> case input of 153 | Adt tag args -> if name == tag && length pats == length args 154 | then isAllMatch args pats 155 | else (scope, False) 156 | _ -> (scope, False) 157 | where isAllMatch items pats = 158 | let (scope', isMatchs) = foldl (\(env, matchs) (item, pat) -> 159 | let (env', isMatch) = match item pat env 160 | in (env', matchs ++ [isMatch])) 161 | (scope, []) $ zip items pats 162 | in (scope', all id isMatchs) 163 | 164 | define :: Pattern -> Value -> ValueScope -> ValueScope 165 | define pattern val scope = case pattern of 166 | IdPattern name -> insert name val scope 167 | TuplePattern pats -> case val of 168 | VTuple items -> defineVals pats items 169 | _ -> error $ "Invalid value " ++ show val ++ " for pattern " ++ show pattern 170 | -- maybe should check pattern name and length of pats and args just like the match function above 171 | TConPattern _ pats -> case val of 172 | Adt _ args -> defineVals pats args 173 | _ -> error $ "Invalid value " ++ show val ++ " for pattern " ++ show pattern 174 | _ -> scope 175 | where defineVals pats items = foldl (\env (pat, item) -> define pat item env) 176 | scope $ zip pats items 177 | 178 | eval :: Expr -> ValueScope -> (ValueScope, Value) 179 | eval expr scope = case expr of 180 | ENum v -> (scope, VNum v) 181 | EBool v -> (scope, VBool v) 182 | EChar v -> (scope, VChar v) 183 | EStr v -> (scope, makeList $ map VChar v) 184 | EUnit -> (scope, VUnit) 185 | EVar name -> case lookup name scope of 186 | Just val -> (scope, val) 187 | Nothing -> error $ "Unknown identifier " ++ show expr 188 | EAccessor obj field -> 189 | case eval obj scope of 190 | (_, VRecord pairs) -> case M.lookup field pairs of 191 | Just val -> (scope, val) 192 | Nothing -> error $ "No field " ++ field ++ "in "++ show obj 193 | _ -> error $ "Not a record " ++ show obj 194 | ETuple values -> (scope, VTuple $ map (\v -> snd (eval v scope)) values) 195 | EList values -> (scope, makeList $ map (\v -> snd (eval v scope)) values) 196 | ERecord pairs -> (scope, VRecord $ M.map (\v -> snd (eval v scope)) pairs) 197 | ELambda params _ instrs -> 198 | let fnV = case reverse params of 199 | (Named name _):xs -> fnChain where 200 | lastFn = chaininLastFn name instrs 201 | fnChain = foldl (\fn (Named n _) -> chainingFn n fn) lastFn xs 202 | _ -> VUnit 203 | in (scope, envCapturingFnWrapper fnV expr scope) 204 | EApp fn arg -> 205 | case fnV of 206 | Fn f -> 207 | let (_, argV) = eval arg scope' 208 | in (scope, f argV scope') 209 | Adt _ _ -> 210 | case eval arg scope' of 211 | (_, VUnit) -> (scope, fnV) 212 | _ -> error $ "Error while evaluating " ++ show expr ++ ": " ++ show fnV ++ " constructor doesn't take arguments" 213 | _ -> error $ "Error while evaluating " ++ show expr ++ ": " ++ show fnV ++ " is not a function" 214 | where scope' = child scope 215 | (_, fnV) = eval fn scope' 216 | EIf cond thenInstrs elseInstrs -> 217 | let (_, condV) = eval cond scope 218 | in case condV of 219 | VBool v -> 220 | if v 221 | then (scope, evalInstrs thenInstrs) 222 | else (scope, evalInstrs elseInstrs) 223 | where evalInstrs instrs = 224 | let scope' = child scope 225 | in snd $ foldl (\(env, val) instr -> val `seq` eval instr env) 226 | (scope', VUnit) 227 | instrs 228 | _ -> error $ "Error while evaluating " ++ show expr ++ ": the condition is not a boolean" 229 | EPatternMatching input cases -> findPattern inputV cases 230 | where (_, inputV) = eval input scope 231 | findPattern :: Value -> [Case] -> (ValueScope, Value) 232 | findPattern val [] = 233 | error $ "Match exception: " ++ show input ++ " = " ++ show val ++ " didn't match any case of " ++ show expr 234 | findPattern val ((Case pat instrs):cs) = 235 | let (scope', isMatch) = match val pat $ child scope 236 | in if isMatch 237 | then (scope, snd $ foldl (\(env, val') instr -> 238 | val' `seq` eval instr env) (scope', VUnit) instrs) 239 | else findPattern val cs 240 | ELetBinding name def body -> 241 | let (scope', _) = eval (EDestructLetBinding name [] [def]) scope 242 | in (scope, snd $ foldl (\(env, val) instr -> val `seq` eval instr env) (scope', VUnit) body) 243 | EDestructLetBinding main args instrs -> 244 | if length args == 0 245 | -- define variable 246 | then let (_, val) = foldl (\(env, val') instr -> val' `seq` eval instr env) (child scope, VUnit) instrs 247 | in (define main val scope, val) 248 | -- define function 249 | else case main of 250 | IdPattern name -> 251 | let fnV = case reverse args of 252 | pat:pats -> fnChain 253 | where lastFn = destrChaininLastFn pat instrs 254 | fnChain = foldl (\fn p -> destrChainingFn p fn) lastFn pats 255 | _ -> VUnit 256 | in let fn = envCapturingFnWrapper fnV expr scope 257 | in (insert name fn scope, fn) 258 | _ -> error $ "Function name can only be a name, whereas a pattern " ++ show main ++ " was provided in " ++ show expr 259 | EDataDecl _ _ _ typeConstructors -> 260 | let scope' = foldl makeChain scope typeConstructors 261 | in (scope', VUnit) 262 | where makeChain env (TypeConstructor name types) = 263 | let fnV = case reverse types of 264 | _:ts -> fnChain where 265 | lastFn = tConChaininLastFn name 266 | fnChain = foldl (\fn _ -> tConChainingFn name fn) 267 | lastFn ts 268 | _ -> VUnit 269 | in if fnV == VUnit 270 | then insert name (Adt name []) env 271 | else insert name fnV env 272 | ETypeSig _ _ -> (scope, VUnit) 273 | EProgram instrs -> foldl (\(env, val) instr -> val `seq` eval instr env) 274 | (child scope, VUnit) instrs 275 | _ -> error $ "not support eval expr: " ++ show expr 276 | -------------------------------------------------------------------------------- /src/Ntha/Parser/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | module Ntha.Parser.Parser where 3 | 4 | import Ntha.State 5 | import Ntha.Core.Ast 6 | import Ntha.Type.Type 7 | import Ntha.Type.Refined (convertProg') 8 | import Ntha.Parser.Lexer 9 | import Control.Monad 10 | import Data.List 11 | import Data.IORef 12 | import Data.Maybe (fromMaybe, fromJust) 13 | import qualified Data.Map as M 14 | import System.IO.Unsafe (unsafePerformIO) 15 | } 16 | 17 | %name expr 18 | %tokentype { Token } 19 | %error { parseError } 20 | 21 | %token 22 | data { DATA } 23 | match { MATCH } 24 | begin { BEGIN } 25 | type { TYPE } 26 | defun { DEFUN } 27 | lambda { LAMBDA } 28 | monad { MONAD } 29 | do { DO } 30 | return { RETURN } 31 | if { IF } 32 | cond { COND } 33 | else { ELSE } 34 | rarrow { RARROW } 35 | larrow { LARROW } 36 | con { CON $$ } 37 | '[' { LBRACKET } 38 | ']' { RBRACKET } 39 | '(' { LPAREN } 40 | ')' { RPAREN } 41 | '{' { LBRACE } 42 | '}' { RBRACE } 43 | '_' { WILDCARD } 44 | '.' { DOT } 45 | ':' { COLON } 46 | '::' { DOUBLECOLON } 47 | '|' { BAR } 48 | let { LET } 49 | import { IMPORT } 50 | TNumber { NUMBERT } 51 | TBool { BOOLT } 52 | TChar { CHART } 53 | TString { STRT } 54 | product { PRODUCT } 55 | keyword { KEYWORD $$ } 56 | VAR { VAR $$ } 57 | TVAR { TVAR $$ } 58 | OPERATOR { OPERATOR $$ } 59 | number { NUMBER $$ } 60 | boolean { BOOLEAN $$ } 61 | string { STRING $$ } 62 | char { CHAR $$ } 63 | 64 | %% 65 | 66 | Program : Exprs { EProgram $1 } 67 | 68 | Exprs : Expr { [$1] } 69 | | Expr Exprs { $1 : $2 } 70 | 71 | Expr : '(' defun VAR '[' Args ']' FormsPlus ')' { EDestructLetBinding (IdPattern $3) $5 $7 } 72 | | '(' data con SimpleArgs VConstructors ')' 73 | { unsafePerformIO $ do 74 | (env, vars) <- 75 | foldM (\(env, vars) arg -> do 76 | var <- makeVariable 77 | return (M.insert arg var env, vars ++ [var])) 78 | (M.empty, []) $4 79 | let dataType = TOper $3 vars 80 | let readEnv scope n = fromMaybe unitT $ M.lookup n scope 81 | let getType arg = case arg of 82 | EVCAVar aname -> readEnv env aname 83 | EVCAOper aname operArgs -> 84 | TOper aname $ map (readEnv env) operArgs 85 | EVCAList arg' -> listT (getType arg') 86 | EVCATuple args -> productT (map getType args) 87 | let constructors' = map (\(EVConstructor cname cargs) -> 88 | let cargs' = map getType 89 | cargs 90 | in TypeConstructor cname cargs') 91 | $5 92 | return $ EDataDecl $3 dataType vars constructors' } 93 | 94 | | '(' let Pattern FormsPlus ')' { EDestructLetBinding $3 [] $4 } 95 | | '(' type con VConArg ')' { unsafePerformIO $ do 96 | $4 `seq` modifyIORef aliasMap $ M.insert $3 $4 97 | return EUnit } 98 | | '(' monad con Form ')' { unsafePerformIO $ do 99 | $4 `seq` modifyIORef monadMap $ M.insert $3 $4 100 | return $ EDestructLetBinding (IdPattern $3) [] [$4] } 101 | | '(' VAR ':' Type ')' { ETypeSig $2 $4 } 102 | | '(' import VAR ')' { EImport (getPathStr $3) } 103 | | Form { $1 } 104 | 105 | -- TODO should support arg parameter such as (Maybe N umber) 106 | SimpleArgs : {- empty -} { [] } 107 | | VAR SimpleArgs { $1 : $2 } 108 | 109 | VConArg : VAR { EVCAVar $1 } 110 | | con { unsafePerformIO $ do 111 | alias <- readIORef aliasMap 112 | case M.lookup $1 alias of 113 | Just vconarg -> return vconarg 114 | Nothing -> if $1 == "String" 115 | -- special case for String pattern 116 | then return $ EVCAList (EVCAOper "Char" []) 117 | else return $ EVCAOper $1 [] } 118 | | '(' con SimpleArgs ')' { EVCAOper $2 $3 } 119 | -- TODO more specs here 120 | | '[' VConArg ']' { EVCAList $2 } 121 | | '(' TupleVConArgs ')' { EVCATuple $2 } 122 | 123 | TupleVConArgs : VConArg '.' VConArg { [$1, $3] } 124 | | TupleVConArgs '.' VConArg { $1 ++ [$3] } 125 | 126 | VConArgs : VConArg { [$1] } 127 | | VConArg VConArgs { $1 : $2 } 128 | 129 | VConstructor : con { EVConstructor $1 [] } 130 | | '(' con VConArgs ')' { EVConstructor $2 $3 } 131 | | '(' VConArg keyword VConArg ')' { EVConstructor $3 [$2, $4] } 132 | 133 | VConstructors : VConstructor { [$1] } 134 | | VConstructor VConstructors { $1 : $2 } 135 | 136 | Args : {- empty -} { [] } 137 | | Pattern Args { $1 : $2 } 138 | 139 | Nameds : {- empty -} { [] } 140 | | VAR Nameds { (Named $1 Nothing) : $2 } 141 | | '(' VAR ':' Type ')' Nameds { (Named $2 (Just $4)) : $6 } 142 | 143 | binding : Pattern Form { ELetBinding $1 $2 [] } 144 | 145 | bindings : binding { [$1] } 146 | | binding bindings { $1 : $2 } 147 | 148 | bind : Form { Single $1 } 149 | | '(' return Form ')' { Return $3 } 150 | | '(' VAR larrow Form ')' { Bind $2 $4 } 151 | 152 | binds : bind { [$1] } 153 | | bind binds { $1 : $2 } 154 | 155 | Clause : '(' else rarrow Form ')' { Else $4 } 156 | | '(' Form rarrow Form ')' { Clause $2 $4 } 157 | 158 | Clauses : Clause { [$1] } 159 | | Clause Clauses { $1 : $2 } 160 | 161 | Form : '(' match Form Cases ')' { EPatternMatching $3 $4 } 162 | | '(' lambda Nameds rarrow FormsPlus ')' { ELambda $3 Nothing $5 } 163 | | '(' lambda Nameds ':' AtomType rarrow FormsPlus ')' { ELambda $3 (Just $5) $7 } 164 | | '(' let '[' bindings ']' FormsPlus ')' { head $ foldr (\(ELetBinding pat def _) body -> 165 | [ELetBinding pat def body]) $6 $4 } 166 | | '(' if Form Form Form ')' { EIf $3 [$4] [$5] } 167 | | '(' cond Clauses ')' { case last $3 of 168 | Else alt -> foldr (\(Clause cond consequent) alternative -> 169 | EIf cond [consequent] [alternative]) 170 | alt 171 | (init $3) 172 | _ -> error "last clause in cond should be an else" } 173 | -- do block desuger to nested >>= and return, inspired by http://www.haskellforall.com/2014/10/how-to-desugar-haskell-code.html 174 | | '(' do con binds ')' 175 | { unsafePerformIO $ do 176 | monads <- readIORef monadMap 177 | return $ 178 | case M.lookup $3 monads of 179 | Just (ERecord pairs) -> 180 | case M.lookup "return" pairs of 181 | Just rtn -> 182 | case M.lookup ">>=" pairs of 183 | Just bind -> 184 | foldr (\b next -> 185 | case next of 186 | EUnit -> 187 | case b of 188 | Bind n e -> error "illegal do expression" 189 | Return e -> EApp newRtn e 190 | Single e -> e 191 | _ -> 192 | case b of 193 | Bind n e -> EApp (EApp newBind e) 194 | (ELambda [Named n Nothing] Nothing [next]) 195 | Return e -> EApp newRtn e 196 | Single e -> e) 197 | EUnit 198 | $4 199 | where newBind = aliasArgName bind 200 | newRtn = aliasArgName rtn 201 | Nothing -> error $ "bind function is not defined for " ++ $3 ++ " monad" 202 | Nothing -> error $ "return function is not defined for " ++ $3 ++ " monad" 203 | _ -> error $ $3 ++ " monad is not defined" } 204 | 205 | | '(' ListForms ')' { $2 } 206 | | '(' TupleFroms ')' { ETuple $2 } 207 | | '(' Form FormsPlus ')' { foldl (\oper param -> (EApp oper param)) $2 $3 } 208 | | '(' Form keyword Form ')' { foldl (\oper param -> (EApp oper param)) 209 | (EVar $3) 210 | [$2, $4] } 211 | | '(' OPERATOR FormsPlus ')' { case $3 of 212 | a:[] -> EApp (EVar $2) a 213 | a:b:[] -> EApp (EApp (EVar $2) a) b 214 | a:b:xs -> foldl (\oper param -> 215 | (EApp (EApp (EVar $2) oper) param)) 216 | (EApp (EApp (EVar $2) a) b) 217 | xs } 218 | | '[' FormsStar ']' { EList $2 } 219 | | '{' RecordForms '}' { ERecord $2 } 220 | | '(' keyword Form ')' { EAccessor $3 $2 } 221 | | '(' begin Exprs ')' { EProgram $3 } 222 | | Atom { $1 } 223 | 224 | RecordForms : keyword Form { M.singleton $1 $2 } 225 | | RecordForms keyword Form { M.insert $2 $3 $1 } 226 | 227 | ListForms : Form '::' Form { EApp (EApp (EVar "Cons") $1) $3 } 228 | | Form '::' ListForms { EApp (EApp (EVar "Cons") $1) $3 } 229 | 230 | TupleFroms : Form '.' Form { [$1, $3] } 231 | | TupleFroms '.' Form { $1 ++ [$3] } 232 | 233 | FormsPlus : Form { [$1] } 234 | | Form FormsPlus { $1 : $2 } 235 | 236 | FormsStar : {- empty -} { [] } 237 | | Form FormsStar { $1 : $2 } 238 | 239 | Pattern : '_' { WildcardPattern } 240 | | VAR { IdPattern $1 } 241 | | number { NumPattern $1 } 242 | | boolean { BoolPattern $1 } 243 | | char { CharPattern $1 } 244 | | string { foldr (\p t -> TConPattern "Cons" [p, t]) 245 | (TConPattern "Nil" []) 246 | (map CharPattern $1) } 247 | | con { TConPattern $1 [] } 248 | | '(' con Args ')' { TConPattern $2 $3 } 249 | -- e.g. (t1 :~> t2) 250 | | '(' Pattern keyword Pattern ')' { TConPattern $3 [$2, $4] } 251 | | '(' TuplePatterns ')' { TuplePattern $2 } 252 | | '[' ']' { TConPattern "Nil" [] } 253 | | '[' Patterns ']' { foldr (\p t -> TConPattern "Cons" [p, t]) 254 | (TConPattern "Nil" []) $2 } 255 | | ListPatterns { $1 } 256 | | '(' ListDestructPats ')' { $2 } 257 | 258 | Patterns : Pattern { [$1] } 259 | | Pattern Patterns { $1 : $2 } 260 | 261 | TuplePatterns : Pattern '.' Pattern { [$1, $3] } 262 | | TuplePatterns '.' Pattern { $1 ++ [$3] } 263 | 264 | ListPatterns : Pattern '::' Pattern { TConPattern "Cons" [$1, $3] } 265 | | Pattern '::' ListPatterns { TConPattern "Cons" [$1, $3] } 266 | 267 | ListDestructPats : Pattern '::' Pattern { TConPattern "Cons" [$1 268 | , TConPattern "Cons" [$3, TConPattern "Nil" []]] } 269 | | Pattern '::' ListDestructPats { TConPattern "Cons" [$1, $3] } 270 | 271 | Case : '(' Pattern rarrow FormsPlus ')' { Case $2 $4 } 272 | 273 | Cases : Case { [$1] } 274 | | Case Cases { $1 : $2 } 275 | 276 | Atom : boolean { EBool $1 } 277 | | number { ENum $1 } 278 | | string { EStr $1 } 279 | | char { EChar $1 } 280 | | VAR { EVar $1 } 281 | | OPERATOR { EVar $1 } 282 | | con { EVar $1 } 283 | 284 | -- parsing type 285 | 286 | Type : AtomType { $1 } 287 | | AtomType rarrow Type { arrowT $1 $3 } 288 | 289 | -- TODO support type alias in type signature 290 | AtomType : TVAR { fromJust $ M.lookup $1 tvarMap } 291 | | TNumber { intT } 292 | | TBool { boolT } 293 | | TChar { charT } 294 | | TString { strT } 295 | | con Types { TOper $1 $2 } 296 | | '[' Type ']' { listT $2 } 297 | | '(' TupleTypes ')' { productT $2 } 298 | | '(' Type ')' { $2 } 299 | | RefinedType { $1 } 300 | 301 | RefinedType : '(' VAR ':' Type '|' Form ')' { TRefined $2 $4 (convertProg' $6) } 302 | 303 | Types : {- empty -} { [] } 304 | | Type Types { $1 : $2 } 305 | 306 | TupleTypes : Type product Type { [$1, $3] } 307 | | TupleTypes product Type { $1 ++ [$3] } 308 | 309 | { 310 | aliasMap :: IORef (M.Map String EVConArg) 311 | aliasMap = createState M.empty 312 | 313 | monadMap :: IORef (M.Map String Expr) 314 | monadMap = createState M.empty 315 | 316 | aliasArgName :: Expr -> Expr 317 | aliasArgName expr@(ELambda nameds t exprs) = substName subrule expr 318 | where 319 | subrule = M.fromList $ foldl (\rule (Named name _) -> rule ++ [(name, name ++ "__monadarg__")]) [] nameds 320 | 321 | {-# NOINLINE tvarMap #-} 322 | tvarMap :: M.Map Char Type 323 | tvarMap = unsafePerformIO $ do 324 | foldM (\m greek -> do 325 | tvar <- makeVariable 326 | return $ M.insert greek tvar m) 327 | M.empty ['α'..'ω'] 328 | 329 | getPathStr :: EPath -> EPath 330 | getPathStr s = (map f s) ++ ".ntha" 331 | where f '.' = '/' 332 | f c = c 333 | 334 | parseError :: [Token] -> a 335 | parseError _ = error "Parse error" 336 | 337 | parseExpr :: String -> Expr 338 | parseExpr = expr . scanTokens 339 | } -------------------------------------------------------------------------------- /test/InferSpec.hs: -------------------------------------------------------------------------------- 1 | module InferSpec where 2 | 3 | import Ntha.Core.Ast 4 | import Ntha.Type.Type 5 | import Ntha.Type.Infer 6 | import Ntha.Core.Prelude 7 | import Ntha.State (resetId, resetUniqueName) 8 | import Control.Monad (foldM) 9 | import qualified Data.Map as M 10 | import qualified Text.PrettyPrint as PP 11 | import qualified Data.Set as S 12 | import Test.Hspec 13 | 14 | runInferSpecCases :: [(Expr, String)] -> IO () 15 | runInferSpecCases exprExpectPairs = do 16 | assumps <- assumptions 17 | (_, types, expects) <- foldM (\(env, types, expects) (expr, expect) -> do 18 | (env', ty) <- analyze expr env S.empty 19 | return (env', types ++ [ty], expects ++ [expect])) 20 | (assumps, [], []) exprExpectPairs 21 | resetId 22 | resetUniqueName 23 | (map (PP.text . show) types) `shouldBe` map PP.text expects 24 | 25 | failInferSpecCase :: Expr -> String -> IO () 26 | failInferSpecCase expr errorMsg = do 27 | assumps <- assumptions 28 | analyze expr assumps S.empty `shouldThrow` errorCall errorMsg 29 | resetId 30 | resetUniqueName 31 | 32 | spec :: Spec 33 | spec = describe "inference test" $ do 34 | it "should infer type of ADT and pattern match expressions part1" $ do 35 | resetId 36 | resetUniqueName 37 | tvarA <- makeVariable 38 | let name = "List" 39 | let vars = [tvarA] 40 | let dataType = TOper name vars 41 | let consConstructor = TypeConstructor "Cons" [tvarA, TOper "List" [tvarA]] 42 | let nilConstructor = TypeConstructor "Nil" [] 43 | let listData = EDataDecl "List" dataType vars [consConstructor, nilConstructor] 44 | (PP.text . show $ listData) `shouldBe` PP.text "data List α = Cons α [α] | Nil" 45 | let xs = EDestructLetBinding (IdPattern "xs") [] [(EVar "Nil")] 46 | let ys = EDestructLetBinding (IdPattern "ys") [] [EApp (EApp (EVar "Cons") $ ENum 5) $ EVar "Nil"] 47 | let len = EDestructLetBinding (IdPattern "len") [IdPattern "l"] [EPatternMatching (EVar "l") [Case (TConPattern "Nil" []) [ENum 0], Case (TConPattern "Cons" [IdPattern "h", IdPattern "t"]) [EApp (EApp (EVar "+") $ ENum 1) $ EApp (EVar "len") $ EVar "t"]]] 48 | let xy = EDestructLetBinding (IdPattern "xy") [] [ETuple [EApp (EVar "len") (EVar "xs"), EApp (EVar "len") (EVar"ys")]] 49 | let zs = EDestructLetBinding (IdPattern "zs") [] [EApp (EApp (EVar "Cons") $ ENum 5) $ EApp (EApp (EVar "Cons") $ ENum 4) $ EApp (EApp (EVar "Cons") $ ENum 3) $ EVar "Nil"] 50 | let z = EDestructLetBinding (IdPattern "z") [] [EApp (EVar "len") $ EVar "zs"] 51 | runInferSpecCases [(listData, "[α]"), 52 | (xs, "[α]"), 53 | (ys, "[Number]"), 54 | (len, "[α] → Number"), 55 | (xy, "(Number * Number)"), 56 | (zs, "[Number]"), 57 | (z, "Number")] 58 | it "should infer type of ADT and pattern match expressions part2" $ do 59 | tvarB <- makeVariable 60 | let name2 = "Tree" 61 | let vars2 = [tvarB] 62 | let dataType2 = TOper name2 vars2 63 | let nullConstructor = TypeConstructor "Null" [] 64 | let leafConstructor = TypeConstructor "Leaf" [tvarB] 65 | let nodeConstructor = TypeConstructor "Node" [dataType2, tvarB, dataType2] 66 | let treeData = EDataDecl name2 dataType2 vars2 [nullConstructor, leafConstructor, nodeConstructor] 67 | let t = EApp (EApp (EApp (EVar "Node") $ EApp (EVar "Leaf") $ ENum 5) $ ENum 4) $ EApp (EVar "Leaf") $ ENum 3 68 | runInferSpecCases [(treeData, "(Tree α)"), 69 | (t, "(Tree Number)")] 70 | it "should infer type of ADT and pattern match expressions part3" $ do 71 | let name3 = "Ast" 72 | let dataType3 = TOper name3 [] 73 | let numConstructor = TypeConstructor "Num" [intT] 74 | let addConstructor = TypeConstructor "Add" [dataType3, dataType3] 75 | let subConstructor = TypeConstructor "Sub" [dataType3, dataType3] 76 | let mulConstructor = TypeConstructor "Mul" [dataType3, dataType3] 77 | let divConstructor = TypeConstructor "Div" [dataType3, dataType3] 78 | let astData = EDataDecl name3 dataType3 [] [numConstructor, addConstructor, subConstructor, mulConstructor, divConstructor] 79 | let eval = EDestructLetBinding (IdPattern "eval") [IdPattern "n"] [EPatternMatching (EVar "n") [Case (TConPattern "Num" [IdPattern "a"]) [EVar "a"],Case (TConPattern "Add" [IdPattern "a", IdPattern "b"]) [EApp (EApp (EVar "+") $ EApp (EVar "eval") $ EVar "a") $ EApp (EVar "eval") $ EVar "b"],Case (TConPattern "Sub" [IdPattern "a", IdPattern "b"]) [EApp (EApp (EVar "-") $ EApp (EVar "eval") $ EVar "a") $ EApp (EVar "eval") $ EVar "b"],Case (TConPattern "Mul" [IdPattern "a", IdPattern "b"]) [EApp (EApp (EVar "*") $ EApp (EVar "eval") $ EVar "a") $ EApp (EVar "eval") $ EVar "b"],Case (TConPattern "Div" [IdPattern "a", IdPattern "b"]) [EApp (EApp (EVar "/") $ EApp (EVar "eval") $ EVar "a") $ EApp (EVar "eval") $ EVar "b"]]] 80 | let sym = EDestructLetBinding (IdPattern "sym") [] [EApp (EApp (EVar "Mul") (EApp (EApp (EVar "Add") $ EApp (EVar "Num") $ ENum 4) $ EApp (EVar "Num") $ ENum 3)) (EApp (EApp (EVar "Sub") $ EApp (EVar "Num") $ ENum 4) $ EApp (EVar "Num") $ ENum 1)] 81 | let result = EDestructLetBinding (IdPattern "result") [] [EApp (EVar "eval") $ EVar "sym"] 82 | runInferSpecCases [(astData, "Ast"), 83 | (eval, "Ast → Number"), 84 | (sym, "Ast"), 85 | (result, "Number")] 86 | it "should infer type of ADT and pattern match expressions part4" $ do 87 | let name4 = "Oper" 88 | let dataType4 = TOper name4 [] 89 | let addOperConstructor = TypeConstructor "Add" [] 90 | let subOperConstructor = TypeConstructor "Sub" [] 91 | let operData = EDataDecl name4 dataType4 [] [addOperConstructor, subOperConstructor] 92 | let name5 = "Expr" 93 | let dataType5 = TOper name5 [] 94 | let numExprConstructor = TypeConstructor "Num" [intT] 95 | let appExprConstructor = TypeConstructor "App" [dataType4, dataType5, dataType5] 96 | let exprData = EDataDecl name5 dataType5 [] [numExprConstructor, appExprConstructor] 97 | let a = EDestructLetBinding (IdPattern "a") [] [EApp (EApp (EApp (EVar "App") $ EVar "Add") $ EApp (EVar "Num") $ ENum 5) $ EApp (EVar "Num") $ ENum 6] 98 | let eval1 = EDestructLetBinding (IdPattern "eval1") [IdPattern "e"] [EPatternMatching (EVar "e") [Case (TConPattern "Num" [IdPattern "n"]) [EVar "n"],Case (TConPattern "App" [IdPattern "o", IdPattern "e1", IdPattern "e2"]) [EPatternMatching (EVar "o") [Case (TConPattern "Add" []) [EApp (EApp (EVar "+") $ EApp (EVar "eval1") $ EVar "e1") $ EApp (EVar "eval1") $ EVar "e2"],Case (TConPattern "Sub" []) [EApp (EApp (EVar "-") $ EApp (EVar "eval1") $ EVar "e1") $ EApp (EVar "eval1") $ EVar "e2"]]]]] 99 | let eval2 = EDestructLetBinding (IdPattern "eval2") [IdPattern "e"] [EPatternMatching (EVar "e") [Case (TConPattern "Num" [IdPattern "n"]) [EVar "n"],Case (TConPattern "App" [TConPattern "Add" [], IdPattern "e1", IdPattern "e2"]) [EApp (EApp (EVar "+") $ EApp (EVar "eval2") $ EVar "e1") $ EApp (EVar "eval2") $ EVar "e2"],Case (TConPattern "App" [TConPattern "Sub" [], IdPattern "e1", IdPattern "e2"]) [EApp (EApp (EVar "-") $ EApp (EVar "eval2") $ EVar "e1") $ EApp (EVar "eval2") $ EVar "e2"]]] 100 | let res1 = EDestructLetBinding (IdPattern "res1") [] [EApp (EVar "eval1") $ EVar "a"] 101 | let res2 = EDestructLetBinding (IdPattern "res2") [] [EApp (EVar "eval2") $ EVar "a"] 102 | let simplify = EDestructLetBinding (IdPattern "simplify") [IdPattern "e"] [EPatternMatching (EVar "e") [Case (TConPattern "App" [TConPattern "Add" [], TConPattern "Num" [IdPattern "n"], IdPattern "e2"]) [EIf (EApp (EApp (EVar "=") $ EVar "n") $ ENum 0) [EVar "e2"] [EVar "e"]]]] 103 | let a2 = EDestructLetBinding (IdPattern "a2") [] [EApp (EApp (EApp (EVar "App") $ EVar "Add") $ EApp (EVar "Num") $ ENum 0) $ EApp (EVar "Num") $ ENum 6] 104 | let b = EDestructLetBinding (IdPattern "b") [] [EApp (EVar "simplify") $ EVar "a2"] 105 | runInferSpecCases [(operData, "Oper"), 106 | (exprData, "Expr"), 107 | (a, "Expr"), 108 | (eval1, "Expr → Number"), 109 | (eval2, "Expr → Number"), 110 | (res1, "Number"), 111 | (res2, "Number"), 112 | (simplify, "Expr → Expr"), 113 | (a2, "Expr"), 114 | (b, "Expr")] 115 | it "should infer type of lambda expressions even with type annotations" $ do 116 | let g = EDestructLetBinding (IdPattern "g") [] [ELambda [Named "x" Nothing, Named "y" Nothing] Nothing [EApp (EApp (EVar "+") $ EVar "x") $ EVar "y"]] 117 | let res0 = EDestructLetBinding (IdPattern "res0") [] [EApp (EApp (EVar "g") $ ENum 3) $ ENum 3] 118 | let f = EDestructLetBinding (IdPattern "f") [] [ELambda [Named "x" (Just intT), Named "y" (Just intT), Named "z" (Just intT)] (Just intT) [EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "x") $ EVar "y")) $ EVar "z"]] 119 | let ff = EDestructLetBinding (IdPattern "ff") [] [ELambda [Named "x" (Just intT), Named "y" (Just boolT), Named "z" (Just intT)] (Just intT) [EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "x") $ EVar "y")) $ EVar "z"]] 120 | let res1 = EDestructLetBinding (IdPattern "res1") [] [EApp (EApp (EApp (EVar "f") $ ENum 8) $ ENum 2) $ ENum 3] 121 | let idfn = EDestructLetBinding (IdPattern "id") [] [ELambda [Named "x" Nothing] Nothing [EVar "x"]] 122 | let res2 = EDestructLetBinding (IdPattern "res2") [] [EApp (EVar "id") $ ENum 3] 123 | let res3 = EDestructLetBinding (IdPattern "res3") [] [EApp (EVar "id") $ EBool True] 124 | -- let polymorphism here!!! 125 | let idpair = ELetBinding (IdPattern "id") (ELambda [Named "x" Nothing] Nothing [EVar "x"]) [(ETuple [EApp (EVar "id") (ENum 3), EApp (EVar "id") (EBool True)])] 126 | let idpair2 = ELetBinding (IdPattern "id") (ELambda [Named "x" Nothing] Nothing [EVar "x"]) [ELetBinding (IdPattern "a") (ENum 3) [ELetBinding (IdPattern "b") (EApp (EApp (EVar "+") $ EVar "a") $ ENum 3) [(ETuple [EApp (EVar "id") (EVar "a"), EApp (EVar "id") (EVar "b")])]]] 127 | let f1 = EDestructLetBinding (IdPattern "f1") [] [ELambda [Named "x" (Just intT), Named "y" (Just intT), Named "z" (Just intT)] (Just intT) [EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "x") $ EVar "y")) $ EVar "z"]] 128 | let f2 = EDestructLetBinding (IdPattern "f2") [] [ELambda [Named "x" Nothing, Named "y" Nothing, Named "z" Nothing] Nothing [EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "x") $ EVar "y")) $ EVar "z"]] 129 | let f1res = EDestructLetBinding (IdPattern "f1res") [] [EApp (EApp (EApp (EVar "f1") $ ENum 8) $ ENum 2) $ ENum 3] 130 | let f2res = EDestructLetBinding (IdPattern "f2res") [] [EApp (EApp (EApp (EVar "f2") $ ENum 8) $ ENum 2) $ ENum 3] 131 | runInferSpecCases [(g, "Number → (Number → Number)"), 132 | (res0, "Number"), 133 | (f, "Number → (Number → (Number → Number))"), 134 | (res1, "Number"), 135 | (idfn, "α → α"), 136 | (res2, "Number"), 137 | (res3, "Boolean"), 138 | (idpair, "(Number * Boolean)"), 139 | (idpair2, "(Number * Number)"), 140 | (f1, "Number → (Number → (Number → Number))"), 141 | (f2, "Number → (Number → (Number → Number))"), 142 | (f1res, "Number"), 143 | (f2res, "Number")] 144 | failInferSpecCase ff "Type mismatch Boolean ≠ Number" 145 | it "should infer type of function definition, application and pattern match" $ do 146 | let fib = EDestructLetBinding (IdPattern "fib") [IdPattern "x"] [EPatternMatching (EVar "x") [Case (NumPattern 0) [ENum 0], Case (NumPattern 1) [ENum 1], Case WildcardPattern [EApp (EApp (EVar "+") $ EApp (EApp (EVar "-") $ EVar "x") $ ENum 1) $ EApp (EApp (EVar "-") $ EVar "x") $ ENum 2]]] 147 | let fib0 = EApp (EVar "fib") $ ENum 0 148 | let penultimate = EProgram [EDestructLetBinding (IdPattern "penultimate") [IdPattern "xs"] [EPatternMatching (EVar "xs") [Case (TConPattern "Nil" []) [ENum 0], 149 | Case (TConPattern "Cons" [WildcardPattern, TConPattern "Nil" []]) [ENum 0], 150 | Case (TConPattern "Cons" [IdPattern "a", TConPattern "Cons" [WildcardPattern, TConPattern "Nil" []]]) [EVar "a"], 151 | Case (TConPattern "Cons" [IdPattern "x", TConPattern "Cons" [IdPattern "y", IdPattern "t"]]) [EApp (EVar "penultimate") (EVar "t")]]]] 152 | let res4 = EDestructLetBinding (IdPattern "res4") [] [EApp (EVar "penultimate") (EList [ENum 1, ENum 2, ENum 3])] 153 | let map1 = EDestructLetBinding (IdPattern "map") [IdPattern "f", IdPattern "l"] [EPatternMatching (EVar "l") [Case (TConPattern "Cons" [IdPattern "h", IdPattern "t"]) [EApp (EApp (EVar "Cons") $ EApp (EVar "f") $ EVar "h") $ EApp (EApp (EVar "map") $ EVar "f") $ EVar "t"],Case (TConPattern "Nil" []) [EVar "Nil"]]] 154 | let map2 = EDestructLetBinding (IdPattern "map2") [IdPattern "f", IdPattern "xs"] [EPatternMatching (EVar "xs") [Case (TConPattern "Nil" []) [EList []],Case (TConPattern "Cons" [IdPattern "h", IdPattern "t"]) [EApp (EApp (EVar "Cons") $ EApp (EVar "f") $ EVar "h") $ EApp (EApp (EVar "map2") $ EVar "f") $ EVar "t"]]] 155 | let l = EDestructLetBinding (IdPattern "l") [] [EList [ENum 1, ENum 2, ENum 3]] 156 | let l3 = EDestructLetBinding (IdPattern "l3") [] [EApp (EApp (EVar "map") $ ELambda [Named "x" Nothing] Nothing [EApp (EApp (EVar "=") $ EApp (EApp (EVar "%") $ EVar "x") $ ENum 2) $ ENum 0]) $ EVar "l"] 157 | let k = EDestructLetBinding (IdPattern "k") [IdPattern "x", IdPattern "y"] [EPatternMatching (ETuple [EVar "x", EVar "y"]) [Case (TuplePattern [NumPattern 0, NumPattern 0]) [ENum 0], Case WildcardPattern [ENum 1]]] 158 | let fact = EDestructLetBinding (IdPattern "fact") [IdPattern "n"] [EIf (EApp (EApp (EVar "≤") $ EVar "n") $ ENum 1) [ENum 1] [EApp (EApp (EVar "*") $ EVar "n") (EApp (EVar "fact") $ EApp (EApp (EVar "-") $ EVar "n") $ ENum 1)]] 159 | let f5 = EDestructLetBinding (IdPattern "f5") [] [EApp (EVar "fact") $ ENum 5] 160 | let comp = EDestructLetBinding (IdPattern "comp") [IdPattern "f", IdPattern "g", IdPattern "x"] [EApp (EVar "f") (EApp (EVar "g") (EVar "x"))] 161 | let fix = EDestructLetBinding (IdPattern "fix") [] [EApp (EApp (EVar "comp") $ EVar "inc") (EVar "dec")] 162 | let incdec = EDestructLetBinding (IdPattern "incdec") [] [EApp (EVar "fix") (ENum 5)] 163 | let len = EDestructLetBinding (IdPattern "len") [IdPattern "xs"] [EPatternMatching (EVar "xs") [Case (TConPattern "Nil" []) [ENum 0],Case (TConPattern "Cons" [WildcardPattern, IdPattern "t"]) [EApp (EApp (EVar "+") $ ENum 1) (EApp (EVar "len") $ EVar "t")]]] 164 | let lenl = EApp (EVar "len") $ EVar "l" 165 | let append = EDestructLetBinding (IdPattern "append") [IdPattern "x", IdPattern "xs"] [EApp (EApp (EVar "Cons") $ EVar "x") $ EVar "xs"] 166 | let l2 = EDestructLetBinding (IdPattern "l2") [] [EApp (EApp (EVar "append") $ ENum 0) $ EVar "l"] 167 | let patmat0 = EDestructLetBinding (IdPattern "patmat0") [] [EPatternMatching (ETuple [EStr "a", ENum 3]) [Case (IdPattern "a") [ETuple [EStr "ok", EVar "a"]]]] 168 | let patmat1 = EDestructLetBinding (IdPattern "patmat1") [] [EPatternMatching (ETuple [EStr "a", ENum 3]) [Case (TuplePattern [IdPattern "a", IdPattern "b"]) [ETuple [EStr "ok", EVar "a", EVar "b"]]]] 169 | let patmat2 = EDestructLetBinding (IdPattern "patmat2") [] [EPatternMatching (ETuple [EStr "a", ENum 3]) [Case (TuplePattern [IdPattern "a", WildcardPattern]) [ETuple [EStr "ok", EVar "a"]]]] 170 | let patmat3 = EDestructLetBinding (IdPattern "patmat3") [] [EPatternMatching (EChar 'a') [Case (CharPattern 'a') [EBool True], Case WildcardPattern [EBool False]]] 171 | let patmat4 = EDestructLetBinding (IdPattern "patmat4") [] [EPatternMatching (EBool True) [Case (BoolPattern True) [EBool True], Case WildcardPattern [EBool False]]] 172 | let patmat5 = EDestructLetBinding (IdPattern "patmat5") [] [EPatternMatching (ENum 1) [Case (NumPattern 1) [EBool True], Case WildcardPattern [EBool False]]] 173 | let patmat6 = EDestructLetBinding (IdPattern "patmat6") [] [EPatternMatching (EStr "abc") [Case (TConPattern "Cons" [CharPattern 'a', (TConPattern "Cons" [CharPattern 'b', (TConPattern "Cons" [CharPattern 'c', TConPattern "Nil" []])])]) [EBool True], Case WildcardPattern [EBool False]]] 174 | runInferSpecCases [(fib, "Number → Number"), 175 | (fib0, "Number"), 176 | (penultimate, "[Number] → Number"), 177 | (res4, "Number"), 178 | (map1, "(α → β) → ([α] → [β])"), 179 | (map2, "(α → β) → ([α] → [β])"), 180 | (l, "[Number]"), 181 | (l3, "[Boolean]"), 182 | (k, "Number → (Number → Number)"), 183 | (fact, "Number → Number"), 184 | (f5, "Number"), 185 | (comp, "(β → γ) → ((α → β) → (α → γ))"), 186 | (fix, "Number → Number"), 187 | (incdec, "Number"), 188 | (len, "[α] → Number"), 189 | (lenl, "Number"), 190 | (append, "α → ([α] → [α])"), 191 | (l2, "[Number]"), 192 | (patmat0, "([Char] * ([Char] * Number))"), 193 | (patmat1, "([Char] * [Char] * Number)"), 194 | (patmat2, "([Char] * [Char])"), 195 | (patmat3, "Boolean"), 196 | (patmat4, "Boolean"), 197 | (patmat5, "Boolean"), 198 | (patmat6, "Boolean")] 199 | it "should infer type of basic syntax element" $ do 200 | let xb = EDestructLetBinding (IdPattern "x") [] [EBool True] 201 | let d = EDestructLetBinding (IdPattern "d") [] [ETuple [ETuple [ENum 4, EBool True], ETuple [EStr "test", EChar 'c', ENum 45]]] 202 | let intsum = EApp (EApp (EVar "+") (EApp (EApp (EVar "+") (EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ ENum 1) $ ENum 2)) $ ENum 3)) $ ENum 4)) $ ENum 5 203 | let l = EDestructLetBinding (IdPattern "y") [] [EList [ENum 1, ENum 2, ENum 3]] 204 | let l2 = EDestructLetBinding (IdPattern "z") [] [EList []] 205 | let a = EDestructLetBinding (IdPattern "a") [] [EChar 'a'] 206 | let s = EDestructLetBinding (IdPattern "s") [] [EStr "qdsfsdf"] 207 | let l3 = EDestructLetBinding (IdPattern "l") [] [EApp (EApp (EVar "Cons") $ ENum 1) $ EApp (EApp (EVar "Cons") $ ENum 2) $ EApp (EApp (EVar "Cons") $ ENum 3) $ EVar "Nil"] 208 | let profile = EDestructLetBinding (IdPattern "profile") [] [ERecord (M.fromList [("name", EStr "ntha"), ("age", ENum 12)])] 209 | let name = EAccessor (EVar "profile") "name" 210 | let equal = (EApp (EApp (EVar "=") $ ENum 3) $ ENum 3) 211 | let notequal = (EApp (EApp (EVar "≠") $ EBool True) $ EBool False) 212 | runInferSpecCases [(xb, "Boolean"), 213 | (d, "((Number * Boolean) * ([Char] * Char * Number))"), 214 | (intsum, "Number"), 215 | (l, "[Number]"), 216 | (l2, "[α]"), 217 | (a, "Char"), 218 | (s, "[Char]"), 219 | (l3, "[Number]"), 220 | (profile, "{age: Number, name: [Char]}"), 221 | (name, "[Char]"), 222 | (equal, "Boolean"), 223 | (notequal, "Boolean")] 224 | it "should infer type of destructuring" $ do 225 | let abpair = EDestructLetBinding (TuplePattern [IdPattern "a", IdPattern "b"]) [] [ETuple [ENum 3, EStr "d"]] 226 | let d = EDestructLetBinding (IdPattern "d") [] [ETuple [ETuple [ENum 3, EBool True], ETuple [EStr "test", EChar 'c', EVar "a"]]] 227 | let bool = EDestructLetBinding (TuplePattern [TuplePattern [WildcardPattern, IdPattern "bool"], TuplePattern [WildcardPattern, WildcardPattern, WildcardPattern]]) [] [EVar "d"] 228 | let boolv = EVar "bool" 229 | let abctuple = ELetBinding (TuplePattern [IdPattern "a", IdPattern "b", IdPattern "c"]) (ETuple [ENum 1, ENum 2, ENum 3]) [(EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "a") $ EVar "b")) $ EVar "c")] 230 | let abclist = EDestructLetBinding (TConPattern "Cons" [IdPattern "a", TConPattern "Cons" [IdPattern "b", TConPattern "Cons" [IdPattern "c", TConPattern "Nil" []]]]) [] [EList [ENum 1, ENum 2, ENum 3]] 231 | let a = EVar "a" 232 | let b = EVar "b" 233 | let c = EVar "c" 234 | let abclist2 = ELetBinding (TConPattern "Cons" [IdPattern "a", TConPattern "Cons" [IdPattern "b", TConPattern "Cons" [IdPattern "c", TConPattern "Nil" []]]]) (EList [ENum 1, ENum 2, ENum 3]) [(EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "a") $ EVar "b")) $ EVar "c")] 235 | let abctuplefn = EDestructLetBinding (IdPattern "f1") [(TuplePattern [IdPattern "a", IdPattern "b", IdPattern "c"])] [(EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "a") $ EVar "b")) $ EVar "c")] 236 | let abclistfn = EDestructLetBinding (IdPattern "f2") [(TConPattern "Cons" [IdPattern "a", TConPattern "Cons" [IdPattern "b", TConPattern "Cons" [IdPattern "c", TConPattern "Nil" []]]])] [(EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "a") $ EVar "b")) $ EVar "c")] 237 | let res1 = EApp (EVar "f1") $ ETuple [EVar "a", EVar "b", EVar "c"] 238 | let res2 = EApp (EVar "f2") $ EList [EVar "a", EVar "b", EVar "c"] 239 | tvarA <- makeVariable 240 | let name = "Maybe" 241 | let vars = [tvarA] 242 | let dataType = TOper name vars 243 | let justConstructor = TypeConstructor "Just" [tvarA] 244 | let nothingConstructor = TypeConstructor "Nothing" [] 245 | let maybeData = EDataDecl name dataType vars [justConstructor, nothingConstructor] 246 | let f = EDestructLetBinding (IdPattern "f3") [(TConPattern "Just" [IdPattern "a"])] [(EApp (EApp (EVar "+") $ EVar "a") $ ENum 1)] 247 | let res3 = EApp (EVar "f3") $ EApp (EVar "Just") $ ENum 2 248 | let just = EDestructLetBinding (TConPattern "Just" [IdPattern "k"]) [] [EApp (EVar "Just") $ ENum 3] 249 | let k = EVar "k" 250 | runInferSpecCases [(abpair, "(Number * [Char])"), 251 | (d, "((Number * Boolean) * ([Char] * Char * Number))"), 252 | (bool, "((Number * Boolean) * ([Char] * Char * Number))"), 253 | (boolv, "Boolean"), 254 | (abctuple, "Number"), 255 | (a, "Number"), 256 | (b, "Number"), 257 | (c, "Number"), 258 | (abclist, "[Number]"), 259 | (abclist2, "Number"), 260 | (abctuplefn, "(Number * Number * Number) → Number"), 261 | (abclistfn, "[Number] → Number"), 262 | (res1, "Number"), 263 | (res2, "Number"), 264 | (maybeData, "(Maybe α)"), 265 | (f, "(Maybe Number) → Number"), 266 | (res3, "Number"), 267 | (just, "(Maybe Number)"), 268 | (k, "Number")] 269 | -------------------------------------------------------------------------------- /test/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | module ParserSpec where 2 | 3 | import Ntha.Core.Ast 4 | import Ntha.Type.Type 5 | import Ntha.Parser.Parser 6 | import qualified Data.Map as M 7 | import qualified Text.PrettyPrint as PP 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "parser test" $ do 13 | it "should parse ADT and pattern match expressions part1" $ do 14 | tvarA <- makeVariable 15 | let name = "List" 16 | let vars = [tvarA] 17 | let dataType = TOper name vars 18 | let consConstructor = TypeConstructor "Cons" [tvarA, dataType] 19 | let nilConstructor = TypeConstructor "Nil" [] 20 | let listData = EDataDecl name dataType vars [consConstructor, nilConstructor] 21 | ((PP.text . show) (parseExpr "(data List a (Cons a (List a)) Nil)")) `shouldBe` ((PP.text . show) (EProgram [listData])) 22 | parseExpr "(let xs Nil)" `shouldBe` EProgram [EDestructLetBinding (IdPattern "xs") [] [(EVar "Nil")]] 23 | parseExpr "(let ys (Cons 5 Nil))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "ys") [] [EApp (EApp (EVar "Cons") $ ENum 5) $ EVar "Nil"]] 24 | parseExpr "(ƒ len [l] (match l (Nil ⇒ 0) ((Cons h t) ⇒ (+ 1 (len t)))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "len") [IdPattern "l"] [EPatternMatching (EVar "l") [Case (TConPattern "Nil" []) [ENum 0], 25 | Case (TConPattern "Cons" [IdPattern "h", IdPattern "t"]) [EApp (EApp (EVar "+") $ ENum 1) $ EApp (EVar "len") $ EVar "t"]]]] 26 | parseExpr "(let xy ((len xs) . (len ys)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "xy") [] [ETuple [EApp (EVar "len") (EVar "xs"), EApp (EVar "len") (EVar"ys")]]] 27 | parseExpr "(let zs (Cons 5 (Cons 4 (Cons 3 Nil))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "zs") [] [EApp (EApp (EVar "Cons") $ ENum 5) $ EApp (EApp (EVar "Cons") $ ENum 4) $ EApp (EApp (EVar "Cons") $ ENum 3) $ EVar "Nil"]] 28 | parseExpr "(let z (len zs))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "z") [] [EApp (EVar "len") $ EVar "zs"]] 29 | it "should parse ADT and pattern match expressions part2" $ do 30 | tvarB <- makeVariable 31 | let name2 = "Tree" 32 | let vars2 = [tvarB] 33 | let dataType2 = TOper name2 vars2 34 | let nullConstructor = TypeConstructor "Null" [] 35 | let leafConstructor = TypeConstructor "Leaf" [tvarB] 36 | let nodeConstructor = TypeConstructor "Node" [dataType2, tvarB, dataType2] 37 | let treeData = EDataDecl name2 dataType2 vars2 [nullConstructor, leafConstructor, nodeConstructor] 38 | ((PP.text . show) (parseExpr "(data Tree a Null (Leaf a) (Node (Tree a) a (Tree a)))")) `shouldBe` ((PP.text . show) (EProgram [treeData])) 39 | parseExpr "(let t (Node (Leaf 5) 4 (Leaf 3)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "t") [] [EApp (EApp (EApp (EVar "Node") $ EApp (EVar "Leaf") $ ENum 5) $ ENum 4) $ EApp (EVar "Leaf") $ ENum 3]] 40 | it "should parse ADT and pattern match expressions part3" $ do 41 | let name3 = "Ast" 42 | let dataType3 = TOper name3 [] 43 | let numConstructor = TypeConstructor "Num" [intT] 44 | let addConstructor = TypeConstructor "Add" [dataType3, dataType3] 45 | let subConstructor = TypeConstructor "Sub" [dataType3, dataType3] 46 | let mulConstructor = TypeConstructor "Mul" [dataType3, dataType3] 47 | let divConstructor = TypeConstructor "Div" [dataType3, dataType3] 48 | let astData = EDataDecl name3 dataType3 [] [numConstructor, addConstructor, subConstructor, mulConstructor, divConstructor] 49 | parseExpr "(data Ast (Num Number) (Add Ast Ast) (Sub Ast Ast) (Mul Ast Ast) (Div Ast Ast))" `shouldBe` EProgram [astData] 50 | parseExpr "(ƒ eval [n] (match n ((Num a) => a) ((Add a b) => (+ (eval a) (eval b))) ((Sub a b) => (- (eval a) (eval b))) ((Mul a b) => (* (eval a) (eval b))) ((Div a b) => (/ (eval a) (eval b)))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "eval") [IdPattern "n"] [EPatternMatching (EVar "n") [Case (TConPattern "Num" [IdPattern "a"]) [EVar "a"], 51 | Case (TConPattern "Add" [IdPattern "a", IdPattern "b"]) [EApp (EApp (EVar "+") $ EApp (EVar "eval") $ EVar "a") $ EApp (EVar "eval") $ EVar "b"], 52 | Case (TConPattern "Sub" [IdPattern "a", IdPattern "b"]) [EApp (EApp (EVar "-") $ EApp (EVar "eval") $ EVar "a") $ EApp (EVar "eval") $ EVar "b"], 53 | Case (TConPattern "Mul" [IdPattern "a", IdPattern "b"]) [EApp (EApp (EVar "*") $ EApp (EVar "eval") $ EVar "a") $ EApp (EVar "eval") $ EVar "b"], 54 | Case (TConPattern "Div" [IdPattern "a", IdPattern "b"]) [EApp (EApp (EVar "/") $ EApp (EVar "eval") $ EVar "a") $ EApp (EVar "eval") $ EVar "b"]]]] 55 | parseExpr "(let sym (Mul (Add (Num 4) (Num 3)) (Sub (Num 4) (Num 1))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "sym") [] [EApp (EApp (EVar "Mul") (EApp (EApp (EVar "Add") $ EApp (EVar "Num") $ ENum 4) $ EApp (EVar "Num") $ ENum 3)) (EApp (EApp (EVar "Sub") $ EApp (EVar "Num") $ ENum 4) $ EApp (EVar "Num") $ ENum 1)]] 56 | parseExpr "(let result (eval sym))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "result") [] [EApp (EVar "eval") $ EVar "sym"]] 57 | it "should parse ADT and pattern match expressions part4" $ do 58 | let name4 = "Oper" 59 | let dataType4 = TOper name4 [] 60 | let addOperConstructor = TypeConstructor "Add" [] 61 | let subOperConstructor = TypeConstructor "Sub" [] 62 | let operData = EDataDecl name4 dataType4 [] [addOperConstructor, subOperConstructor] 63 | parseExpr "(data Oper Add Sub)" `shouldBe` EProgram [operData] 64 | let name5 = "Expr" 65 | let dataType5 = TOper name5 [] 66 | let numExprConstructor = TypeConstructor "Num" [intT] 67 | let appExprConstructor = TypeConstructor "App" [dataType4, dataType5, dataType5] 68 | let exprData = EDataDecl name5 dataType5 [] [numExprConstructor, appExprConstructor] 69 | parseExpr "(data Expr (Num Number) (App Oper Expr Expr))" `shouldBe` EProgram [exprData] 70 | parseExpr "(let a (App Add (Num 5) (Num 6)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "a") [] [EApp (EApp (EApp (EVar "App") $ EVar "Add") $ EApp (EVar "Num") $ ENum 5) $ EApp (EVar "Num") $ ENum 6]] 71 | parseExpr "(ƒ eval [e] (match e ((Num n) => n) ((App o e1 e2) => (match o (Add => (+ (eval e1) (eval e2))) (Sub => (- (eval e1) (eval e2)))))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "eval") [IdPattern "e"] [EPatternMatching (EVar "e") [Case (TConPattern "Num" [IdPattern "n"]) [EVar "n"], 72 | Case (TConPattern "App" [IdPattern "o", IdPattern "e1", IdPattern "e2"]) [EPatternMatching (EVar "o") [Case (TConPattern "Add" []) [EApp (EApp (EVar "+") $ EApp (EVar "eval") $ EVar "e1") $ EApp (EVar "eval") $ EVar "e2"], 73 | Case (TConPattern "Sub" []) [EApp (EApp (EVar "-") $ EApp (EVar "eval") $ EVar "e1") $ EApp (EVar "eval") $ EVar "e2"]]]]]] 74 | parseExpr "(ƒ eval [e] (match e ((Num n) => n) ((App Add e1 e2) => (+ (eval e1) (eval e2))) ((App Sub e1 e2) => (- (eval e1) (eval e2)))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "eval") [IdPattern "e"] [EPatternMatching (EVar "e") [Case (TConPattern "Num" [IdPattern "n"]) [EVar "n"], 75 | Case (TConPattern "App" [TConPattern "Add" [], IdPattern "e1", IdPattern "e2"]) [EApp (EApp (EVar "+") $ EApp (EVar "eval") $ EVar "e1") $ EApp (EVar "eval") $ EVar "e2"], 76 | Case (TConPattern "App" [TConPattern "Sub" [], IdPattern "e1", IdPattern "e2"]) [EApp (EApp (EVar "-") $ EApp (EVar "eval") $ EVar "e1") $ EApp (EVar "eval") $ EVar "e2"]]]] 77 | parseExpr "(let av (eval a))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "av") [] [EApp (EVar "eval") $ EVar "a"]] 78 | parseExpr "(ƒ simplify [e] (match e ((App Add (Num n) e2) => (if (= n 0) e2 e))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "simplify") [IdPattern "e"] [EPatternMatching (EVar "e") [Case (TConPattern "App" [TConPattern "Add" [], TConPattern "Num" [IdPattern "n"], IdPattern "e2"]) [EIf (EApp (EApp (EVar "=") $ EVar "n") $ ENum 0) [EVar "e2"] [EVar "e"]]]]] 79 | parseExpr "(let a (App Add (Num 0) (Num 6)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "a") [] [EApp (EApp (EApp (EVar "App") $ EVar "Add") $ EApp (EVar "Num") $ ENum 0) $ EApp (EVar "Num") $ ENum 6]] 80 | parseExpr "(let b (simplify a))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "b") [] [EApp (EVar "simplify") $ EVar "a"]] 81 | it "should parse lambda expressions even with type annotations" $ do 82 | parseExpr "(let g (λx y ⇒ (+ x y)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "g") [] [ELambda [Named "x" Nothing, Named "y" Nothing] Nothing [EApp (EApp (EVar "+") $ EVar "x") $ EVar "y"]]] 83 | parseExpr "(let res0 (g 3 3))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "res0") [] [EApp (EApp (EVar "g") $ ENum 3) $ ENum 3]] 84 | parseExpr "(let id (λx ⇒ x))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "id") [] [ELambda [Named "x" Nothing] Nothing [EVar "x"]]] 85 | parseExpr "(let res2 (id 3))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "res2") [] [EApp (EVar "id") $ ENum 3]] 86 | parseExpr "(let res3 (id true))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "res3") [] [EApp (EVar "id") $ EBool True]] 87 | parseExpr "(let [id (λx ⇒ x)] ((id 3) . (id true)))" `shouldBe` EProgram [ELetBinding (IdPattern "id") (ELambda [Named "x" Nothing] Nothing [EVar "x"]) [(ETuple [EApp (EVar "id") (ENum 3), EApp (EVar "id") (EBool True)])]] 88 | parseExpr "(let [id (λx ⇒ x) a 3 b (+ a 3)] ((id a) . (id b)))" `shouldBe` EProgram [ELetBinding (IdPattern "id") (ELambda [Named "x" Nothing] Nothing [EVar "x"]) [ELetBinding (IdPattern "a") (ENum 3) [ELetBinding (IdPattern "b") (EApp (EApp (EVar "+") $ EVar "a") $ ENum 3) [(ETuple [EApp (EVar "id") (EVar "a"), EApp (EVar "id") (EVar "b")])]]]] 89 | parseExpr "(let f (λ(x: Number) (y: Number) (z: Number) : Number => (+ x y z)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "f") [] [ELambda [Named "x" (Just intT), Named "y" (Just intT), Named "z" (Just intT)] (Just intT) [EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "x") $ EVar "y")) $ EVar "z"]]] 90 | parseExpr "(let f (λx y z => (+ x y z)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "f") [] [ELambda [Named "x" Nothing, Named "y" Nothing, Named "z" Nothing] Nothing [EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "x") $ EVar "y")) $ EVar "z"]]] 91 | parseExpr "(let res (f 8 2 3))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "res") [] [EApp (EApp (EApp (EVar "f") $ ENum 8) $ ENum 2) $ ENum 3]] 92 | it "should parse function definition, application and pattern match" $ do 93 | parseExpr "(ƒ fib [x]\n (match x\n (0 => 0)\n (1 => 1)\n (_ => (+ (fib (- x 1)) (fib (- x 2))))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "fib") [IdPattern "x"] [EPatternMatching (EVar "x") [Case (NumPattern 0) [ENum 0], 94 | Case (NumPattern 1) [ENum 1], 95 | Case WildcardPattern [EApp (EApp (EVar "+") (EApp (EVar "fib") $ EApp (EApp (EVar "-") $ EVar "x") $ ENum 1)) $ EApp (EVar "fib") $ EApp (EApp (EVar "-") $ EVar "x") $ ENum 2]]]] 96 | parseExpr "(ƒ penultimate [xs]\n (match xs\n ([] => 0)\n ([_] => 0)\n ([a _] => a)\n (x :: y :: t => (penultimate t))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "penultimate") [IdPattern "xs"] [EPatternMatching (EVar "xs") [Case (TConPattern "Nil" []) [ENum 0], 97 | Case (TConPattern "Cons" [WildcardPattern, TConPattern "Nil" []]) [ENum 0], 98 | Case (TConPattern "Cons" [IdPattern "a", TConPattern "Cons" [WildcardPattern, TConPattern "Nil" []]]) [EVar "a"], 99 | Case (TConPattern "Cons" [IdPattern "x", TConPattern "Cons" [IdPattern "y", IdPattern "t"]]) [EApp (EVar "penultimate") (EVar "t")]]]] 100 | parseExpr "(let res4 (penultimate [1 2 3]))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "res4") [] [EApp (EVar "penultimate") (EList [ENum 1, ENum 2, ENum 3])]] 101 | parseExpr "(let x (penultimate [[\"g\"] [\"c\"]]))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "x") [] [EApp (EVar "penultimate") (EList [EList [EStr "g"], EList [EStr "c"]])]] 102 | parseExpr "(ƒ map [f l] (match l ((Cons h t) => (Cons (f h) (map f t))) (Nil => Nil)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "map") [IdPattern "f", IdPattern "l"] [EPatternMatching (EVar "l") [Case (TConPattern "Cons" [IdPattern "h", IdPattern "t"]) [EApp (EApp (EVar "Cons") $ EApp (EVar "f") $ EVar "h") $ EApp (EApp (EVar "map") $ EVar "f") $ EVar "t"], 103 | Case (TConPattern "Nil" []) [EVar "Nil"]]]] 104 | parseExpr "(ƒ map [f xs] (match xs ([] ⇒ []) (h :: t ⇒ ((f h) :: (map f t)))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "map") [IdPattern "f", IdPattern "xs"] [EPatternMatching (EVar "xs") [Case (TConPattern "Nil" []) [EList []], 105 | Case (TConPattern "Cons" [IdPattern "h", IdPattern "t"]) [EApp (EApp (EVar "Cons") $ EApp (EVar "f") $ EVar "h") $ EApp (EApp (EVar "map") $ EVar "f") $ EVar "t"]]]] 106 | parseExpr "(let l3 (map (λx => (= (% x 2) 0)) l))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "l3") [] [EApp (EApp (EVar "map") $ ELambda [Named "x" Nothing] Nothing [EApp (EApp (EVar "=") $ EApp (EApp (EVar "%") $ EVar "x") $ ENum 2) $ ENum 0]) $ EVar "l"]] 107 | parseExpr "(ƒ k [x y] (match (x . y) ((0 . 0) => 0) (_ => 1)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "k") [IdPattern "x", IdPattern "y"] [EPatternMatching (ETuple [EVar "x", EVar "y"]) [Case (TuplePattern [NumPattern 0, NumPattern 0]) [ENum 0], Case WildcardPattern [ENum 1]]]] 108 | parseExpr "(ƒ fact [n] (if (≤ n 1) 1 (* n (fact (- n 1)))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "fact") [IdPattern "n"] [EIf (EApp (EApp (EVar "≤") $ EVar "n") $ ENum 1) [ENum 1] [EApp (EApp (EVar "*") $ EVar "n") (EApp (EVar "fact") $ EApp (EApp (EVar "-") $ EVar "n") $ ENum 1)]]] 109 | parseExpr "(let f5 (fact 5))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "f5") [] [EApp (EVar "fact") $ ENum 5]] 110 | parseExpr "(ƒ comp [f g x] (f (g x)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "comp") [IdPattern "f", IdPattern "g", IdPattern "x"] [EApp (EVar "f") (EApp (EVar "g") (EVar "x"))]] 111 | parseExpr "(let fix (comp inc dec))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "fix") [] [EApp (EApp (EVar "comp") $ EVar "inc") (EVar "dec")]] 112 | parseExpr "(let incdec (fix 5))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "incdec") [] [EApp (EVar "fix") (ENum 5)]] 113 | parseExpr "(ƒ len2 [xs] (match xs ([] => 0) (_ :: t => (+ 1 (len2 t)))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "len2") [IdPattern "xs"] [EPatternMatching (EVar "xs") [Case (TConPattern "Nil" []) [ENum 0], 114 | Case (TConPattern "Cons" [WildcardPattern, IdPattern "t"]) [EApp (EApp (EVar "+") $ ENum 1) (EApp (EVar "len2") $ EVar "t")]]]] 115 | parseExpr "(len2 y)" `shouldBe` EProgram [EApp (EVar "len2") $ EVar "y"] 116 | parseExpr "(ƒ append [x xs] (x :: xs))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "append") [IdPattern "x", IdPattern "xs"] [EApp (EApp (EVar "Cons") $ EVar "x") $ EVar "xs"]] 117 | parseExpr "(let l2 (append 0 l))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "l2") [] [EApp (EApp (EVar "append") $ ENum 0) $ EVar "l"]] 118 | parseExpr "(let patmat0 (match (\"a\" . 3) (a => (\"ok\" . a))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "patmat0") [] [EPatternMatching (ETuple [EStr "a", ENum 3]) [Case (IdPattern "a") [ETuple [EStr "ok", EVar "a"]]]]] 119 | parseExpr "(let patmat1 (match (\"a\" . 3) ((a . b) => (\"ok\" . a . b))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "patmat1") [] [EPatternMatching (ETuple [EStr "a", ENum 3]) [Case (TuplePattern [IdPattern "a", IdPattern "b"]) [ETuple [EStr "ok", EVar "a", EVar "b"]]]]] 120 | parseExpr "(let patmat2 (match (\"a\" . 3) ((a . _) => (\"ok\" . a))))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "patmat2") [] [EPatternMatching (ETuple [EStr "a", ENum 3]) [Case (TuplePattern [IdPattern "a", WildcardPattern]) [ETuple [EStr "ok", EVar "a"]]]]] 121 | parseExpr "(let patmat3 (match 'a' ('a' => true) (_ => false)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "patmat3") [] [EPatternMatching (EChar 'a') [Case (CharPattern 'a') [EBool True], Case WildcardPattern [EBool False]]]] 122 | parseExpr "(let patmat4 (match true (true => true) (_ => false)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "patmat4") [] [EPatternMatching (EBool True) [Case (BoolPattern True) [EBool True], Case WildcardPattern [EBool False]]]] 123 | parseExpr "(let patmat5 (match 1 (1 => true) (_ => false)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "patmat5") [] [EPatternMatching (ENum 1) [Case (NumPattern 1) [EBool True], Case WildcardPattern [EBool False]]]] 124 | parseExpr "(let patmat6 (match \"abc\" (\"abc\" => true) (_ => false)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "patmat6") [] [EPatternMatching (EStr "abc") [Case (TConPattern "Cons" [CharPattern 'a', (TConPattern "Cons" [CharPattern 'b', (TConPattern "Cons" [CharPattern 'c', TConPattern "Nil" []])])]) [EBool True], Case WildcardPattern [EBool False]]]] 125 | it "should parse basic syntax element" $ do 126 | parseExpr "(let x true)" `shouldBe` EProgram [EDestructLetBinding (IdPattern "x") [] [EBool True]] 127 | parseExpr "(let d ((4 . true) . (\"test\" . 'c' . 45)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "d") [] [ETuple [ETuple [ENum 4, EBool True], ETuple [EStr "test", EChar 'c', ENum 45]]]] 128 | parseExpr "(+ 1 2 3 4 5)" `shouldBe` EProgram [EApp (EApp (EVar "+") (EApp (EApp (EVar "+") (EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ ENum 1) $ ENum 2)) $ ENum 3)) $ ENum 4)) $ ENum 5] 129 | parseExpr "(let y [1 2 3])" `shouldBe` EProgram [EDestructLetBinding (IdPattern "y") [] [EList [ENum 1, ENum 2, ENum 3]]] 130 | parseExpr "(let z [])" `shouldBe` EProgram [EDestructLetBinding (IdPattern "z") [] [EList []]] 131 | parseExpr "(let a 'a')" `shouldBe` EProgram [EDestructLetBinding (IdPattern "a") [] [EChar 'a']] 132 | parseExpr "(let s \"qdsfsdf\")" `shouldBe` EProgram [EDestructLetBinding (IdPattern "s") [] [EStr "qdsfsdf"]] 133 | parseExpr "(let l (1 :: 2 :: 3 :: Nil))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "l") [] [EApp (EApp (EVar "Cons") $ ENum 1) $ EApp (EApp (EVar "Cons") $ ENum 2) $ EApp (EApp (EVar "Cons") $ ENum 3) $ EVar "Nil"]] 134 | parseExpr "(let profile {:name \"ntha\" :age 12})" `shouldBe` EProgram [EDestructLetBinding (IdPattern "profile") [] [ERecord (M.fromList [("name", EStr "ntha"), ("age", ENum 12)])]] 135 | parseExpr "(:name profile)" `shouldBe` EProgram [EAccessor (EVar "profile") "name"] 136 | it "should parse cond expression" $ do 137 | parseExpr "(ƒ fact [n] (cond ((≤ n 1) → 1) (else → (* n (fact (- n 1))))))" `shouldBe` parseExpr "(ƒ fact [n] (if (≤ n 1) 1 (* n (fact (- n 1)))))" 138 | parseExpr "(ƒ fib [x] (cond ((= x 0) ⇒ 0) ((= x 1) ⇒ 1) (else ⇒ (+ (fib (- x 1)) (fib (- x 2))))))" `shouldBe` parseExpr "(ƒ fib [x] (if (= x 0) 0 (if (= x 1) 1 (+ (fib (- x 1)) (fib (- x 2))))))" 139 | it "should parse destructuring" $ do 140 | parseExpr "(let (a . b) (3 . \"d\"))" `shouldBe` EProgram [EDestructLetBinding (TuplePattern [IdPattern "a", IdPattern "b"]) [] [ETuple [ENum 3, EStr "d"]]] 141 | parseExpr "(let d ((3 . true) . (\"test\" . 'c' . a)))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "d") [] [ETuple [ETuple [ENum 3, EBool True], ETuple [EStr "test", EChar 'c', EVar "a"]]]] 142 | parseExpr "(let ((_ . bool) . (_ . _ . _)) d)" `shouldBe` EProgram [EDestructLetBinding (TuplePattern [TuplePattern [WildcardPattern, IdPattern "bool"], TuplePattern [WildcardPattern, WildcardPattern, WildcardPattern]]) [] [EVar "d"]] 143 | parseExpr "(let [(a . b . c) (1 . 2 . 3)] (+ a b c))" `shouldBe` EProgram [ELetBinding (TuplePattern [IdPattern "a", IdPattern "b", IdPattern "c"]) (ETuple [ENum 1, ENum 2, ENum 3]) [(EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "a") $ EVar "b")) $ EVar "c")]] 144 | parseExpr "(let (a :: b :: c) [1 2 3])" `shouldBe` EProgram [EDestructLetBinding (TConPattern "Cons" [IdPattern "a", TConPattern "Cons" [IdPattern "b", TConPattern "Cons" [IdPattern "c", TConPattern "Nil" []]]]) [] [EList [ENum 1, ENum 2, ENum 3]]] 145 | parseExpr "(let [(a :: b :: c) [1 2 3]] (+ a b c))" `shouldBe` EProgram [ELetBinding (TConPattern "Cons" [IdPattern "a", TConPattern "Cons" [IdPattern "b", TConPattern "Cons" [IdPattern "c", TConPattern "Nil" []]]]) (EList [ENum 1, ENum 2, ENum 3]) [(EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "a") $ EVar "b")) $ EVar "c")]] 146 | parseExpr "(ƒ f [(a . b . c)] (+ a b c))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "f") [(TuplePattern [IdPattern "a", IdPattern "b", IdPattern "c"])] [(EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "a") $ EVar "b")) $ EVar "c")]] 147 | parseExpr "(ƒ f [(a :: b :: c)] (+ a b c))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "f") [(TConPattern "Cons" [IdPattern "a", TConPattern "Cons" [IdPattern "b", TConPattern "Cons" [IdPattern "c", TConPattern "Nil" []]]])] [(EApp (EApp (EVar "+") (EApp (EApp (EVar "+") $ EVar "a") $ EVar "b")) $ EVar "c")]] 148 | parseExpr "(f (a . b . c))" `shouldBe` EProgram [EApp (EVar "f") $ ETuple [EVar "a", EVar "b", EVar "c"]] 149 | parseExpr "(f [a b c])" `shouldBe` EProgram [EApp (EVar "f") $ EList [EVar "a", EVar "b", EVar "c"]] 150 | tvarA <- makeVariable 151 | let name = "Maybe" 152 | let vars = [tvarA] 153 | let dataType = TOper name vars 154 | let justConstructor = TypeConstructor "Just" [tvarA] 155 | let nothingConstructor = TypeConstructor "Nothing" [] 156 | let maybeData = EDataDecl name dataType vars [justConstructor, nothingConstructor] 157 | ((PP.text . show) (parseExpr "(data Maybe a (Just a) Nothing)")) `shouldBe` ((PP.text . show) (EProgram [maybeData])) 158 | parseExpr "(ƒ f [(Just a)] (+ a 1))" `shouldBe` EProgram [EDestructLetBinding (IdPattern "f") [(TConPattern "Just" [IdPattern "a"])] [(EApp (EApp (EVar "+") $ EVar "a") $ ENum 1)]] 159 | parseExpr "(f (Just 2))" `shouldBe` EProgram [EApp (EVar "f") $ EApp (EVar "Just") $ ENum 2] 160 | parseExpr "(let (Just k) (Just 3))" `shouldBe` EProgram [EDestructLetBinding (TConPattern "Just" [IdPattern "k"]) [] [EApp (EVar "Just") $ ENum 3]] 161 | --------------------------------------------------------------------------------