it can now infer the type of some expressions
This commit is contained in:
parent
748d15d9f7
commit
d3f9de1f05
22
TODO
22
TODO
|
@ -1,16 +1,20 @@
|
||||||
1) Write a Hindley Milner type checker for that injective datatype recursor language
|
*) Fix user defined type stuff
|
||||||
|
|
||||||
https://wikimedia.org/api/rest_v1/media/math/render/svg/431b94815103ac9dc77d0e92739456c3c2c90803
|
*) Implement top level stuff
|
||||||
https://github.com/sdiehl/write-you-a-haskell/blob/master/chapter7/poly_constraints/src/Infer.hs
|
|
||||||
https://github.com/sdiehl/write-you-a-haskell/blob/master/chapter7/poly/src/Infer.hs
|
|
||||||
|
|
||||||
2) Extend it to allow for referencing declerations "further down" in file, but make sure it
|
*) Rewrite type checker to collect and then solve constraints
|
||||||
|
|
||||||
|
*) Extend it to allow for referencing declarations "further down" in file, but make sure it
|
||||||
terminates by forbidding corecursion (simply done by building a reference graph and then looking at it)
|
terminates by forbidding corecursion (simply done by building a reference graph and then looking at it)
|
||||||
|
|
||||||
3) Add Kind env and use it to have "type of types"
|
*) Add Kind env and type parameters
|
||||||
|
|
||||||
4) Type annotated tree?
|
*) Type annotated tree?
|
||||||
|
|
||||||
5) Make SECD machine good enough to execute it
|
*) Make SECD machine good enough to execute it
|
||||||
|
|
||||||
6) Write backend for SECD machine code
|
*) Write backend for SECD machine code
|
||||||
|
|
||||||
|
*) Pattern matching to recursor syntactic sugar
|
||||||
|
|
||||||
|
*) Record types
|
||||||
|
|
40
app/Main.hs
40
app/Main.hs
|
@ -1,2 +1,40 @@
|
||||||
|
import System.Exit
|
||||||
|
|
||||||
|
import Hm.Layout ( resolveLayout )
|
||||||
|
import Hm.Lex ( Token, mkPosToken )
|
||||||
|
import Hm.Par ( pExp, myLexer )
|
||||||
|
import Hm.Print ( Print, printTree )
|
||||||
|
|
||||||
|
import Data.Text (Text)
|
||||||
|
import qualified Data.Text.IO as T
|
||||||
|
|
||||||
|
import qualified Data.Set as S
|
||||||
|
|
||||||
|
import TC (initialState, runCheck, infer, generalize)
|
||||||
|
import PostProcess (expToExp, runProcess)
|
||||||
|
import Pretty
|
||||||
|
|
||||||
|
inferType :: Text -> IO ()
|
||||||
|
inferType s = case pExp ts of
|
||||||
|
Left err -> do
|
||||||
|
putStrLn "\nParse Failed...\n"
|
||||||
|
putStrLn "Tokens:"
|
||||||
|
mapM_ (putStrLn . showPosToken . mkPosToken) ts
|
||||||
|
putStrLn err
|
||||||
|
exitFailure
|
||||||
|
Right tree -> do
|
||||||
|
putStrLn "\nParse Successful!"
|
||||||
|
putStrLn (printTree tree)
|
||||||
|
|
||||||
|
let action = runProcess (expToExp tree) S.empty >>= infer >>= generalize . snd
|
||||||
|
let result = fst (runCheck initialState action)
|
||||||
|
|
||||||
|
case result of
|
||||||
|
Left err -> print err
|
||||||
|
Right res -> T.putStrLn (pretty res)
|
||||||
|
where
|
||||||
|
ts = init (resolveLayout True (myLexer s))
|
||||||
|
showPosToken ((l,c),t) = concat [ show l, ":", show c, "\t", show t ]
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = pure ()
|
main = T.getContents >>= inferType
|
||||||
|
|
3
hm.cabal
3
hm.cabal
|
@ -31,6 +31,7 @@ library
|
||||||
, Type
|
, Type
|
||||||
, Misc
|
, Misc
|
||||||
, PostProcess
|
, PostProcess
|
||||||
|
, Pretty
|
||||||
|
|
||||||
other-modules: Hm.ErrM
|
other-modules: Hm.ErrM
|
||||||
build-tool-depends: alex:alex >= 3.0, happy:happy >= 1.19.5
|
build-tool-depends: alex:alex >= 3.0, happy:happy >= 1.19.5
|
||||||
|
@ -45,6 +46,6 @@ library
|
||||||
|
|
||||||
executable sexprml
|
executable sexprml
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
build-depends: base >=4, hm
|
build-depends: base >=4, hm, text, containers
|
||||||
hs-source-dirs: app
|
hs-source-dirs: app
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
15
hm.cf
15
hm.cf
|
@ -25,16 +25,15 @@ coercions TypeSig 2;
|
||||||
|
|
||||||
separator nonempty TypeSig2 "" ;
|
separator nonempty TypeSig2 "" ;
|
||||||
|
|
||||||
ExpLet. Exp ::= "let" "{" [Assign] "}" "in" Exp2 ;
|
ExpLet. Exp ::= "let" "{" [Assign] "}" "in" Exp1 ;
|
||||||
ExpTyped. Exp1 ::= Exp2 ":" TypeSig ;
|
ExpAbs. Exp1 ::= "λ" [Id] "." Exp1 ;
|
||||||
ExpAbs. Exp2 ::= "λ" [Id] "." Exp3 ;
|
ExpApp. Exp1 ::= Exp2 [Exp2] ;
|
||||||
ExpApp. Exp3 ::= Exp4 [Exp4] ;
|
ExpVar. Exp2 ::= Id ;
|
||||||
ExpVar. Exp4 ::= Id ;
|
|
||||||
|
|
||||||
Assign. Assign ::= Id "=" Exp1 ;
|
Assign. Assign ::= Id ":=" Exp ;
|
||||||
separator nonempty Assign ";" ;
|
separator nonempty Assign ";" ;
|
||||||
|
|
||||||
separator nonempty Exp4 "" ;
|
separator nonempty Exp2 "" ;
|
||||||
coercions Exp 4 ;
|
coercions Exp 2 ;
|
||||||
|
|
||||||
separator nonempty Id "" ;
|
separator nonempty Id "" ;
|
||||||
|
|
|
@ -37,8 +37,10 @@ addDef = \case
|
||||||
|
|
||||||
-- add type before typesig to id params
|
-- add type before typesig to id params
|
||||||
defToTL :: H.Def -> Process TL
|
defToTL :: H.Def -> Process TL
|
||||||
defToTL (H.VarDef p i t e) = VarDef p i <$> typeSigToPolyT t <*> expToExp e
|
defToTL (H.VarDef p i t e) = VarDef <$> lift (setPos p) <*> pure i <*> typeSigToPolyT t <*> expToExp e
|
||||||
defToTL (H.TypeDef p t ds) = do
|
defToTL (H.TypeDef p t ds) = do
|
||||||
|
_ <- lift (setPos p)
|
||||||
|
|
||||||
(i,_) <- typeSigToIdParams t
|
(i,_) <- typeSigToIdParams t
|
||||||
|
|
||||||
let (Id s) = i
|
let (Id s) = i
|
||||||
|
@ -47,7 +49,7 @@ defToTL (H.TypeDef p t ds) = do
|
||||||
let env = M.fromList (map (\(i,m) -> (i, Mono m)) monoT)
|
let env = M.fromList (map (\(i,m) -> (i, Mono m)) monoT)
|
||||||
|
|
||||||
-- check that all constructors construct correct type
|
-- check that all constructors construct correct type
|
||||||
mapM_ (guard (throwError (InvalidConstructor p)) . constructs i . snd) monoT
|
mapM_ (guard (throwError (InvalidConstructor)) . constructs i . snd) monoT
|
||||||
|
|
||||||
-- check that there are no unbound variables
|
-- check that there are no unbound variables
|
||||||
guard (throwError (Unimplemented "Type parameters")) (free env == S.empty)
|
guard (throwError (Unimplemented "Type parameters")) (free env == S.empty)
|
||||||
|
@ -69,8 +71,8 @@ defToTL (H.TypeDef p t ds) = do
|
||||||
|
|
||||||
|
|
||||||
typeSigToIdParams :: H.TypeSig -> Process (Id, [Id])
|
typeSigToIdParams :: H.TypeSig -> Process (Id, [Id])
|
||||||
typeSigToIdParams = \case
|
typeSigToIdParams = lift . setPos >=> \case
|
||||||
H.TypeFun p _ _ -> throwError (InvalidTypeDecl p)
|
H.TypeFun{} -> throwError InvalidTypeDecl
|
||||||
H.TypeApp{} -> throwError (Unimplemented "Type parameters")
|
H.TypeApp{} -> throwError (Unimplemented "Type parameters")
|
||||||
H.TypeVar _ i -> pure (i, [])
|
H.TypeVar _ i -> pure (i, [])
|
||||||
|
|
||||||
|
@ -89,9 +91,13 @@ typeSigToMonoT = \case
|
||||||
expToExp :: H.Exp -> Process Exp
|
expToExp :: H.Exp -> Process Exp
|
||||||
expToExp = \case
|
expToExp = \case
|
||||||
H.ExpLet p as e -> Let p <$> assignTo2pl <~> as <*> expToExp e
|
H.ExpLet p as e -> Let p <$> assignTo2pl <~> as <*> expToExp e
|
||||||
H.ExpTyped p e t -> Typed p <$> expToExp e <*> typeSigToMonoT t
|
|
||||||
H.ExpAbs p is e -> Abs p is <$> expToExp e
|
H.ExpAbs p is e -> Abs p is <$> expToExp e
|
||||||
H.ExpApp p e es -> App p <$> expToExp e <*> expToExp <~> es
|
H.ExpApp p e1 (e2:es) -> do
|
||||||
|
e1' <- expToExp e1
|
||||||
|
e2' <- expToExp e2
|
||||||
|
es' <- traverse expToExp es
|
||||||
|
pure (foldl (App p) (App p e1' e2') es')
|
||||||
|
H.ExpApp p e [] -> throwError Oop
|
||||||
H.ExpVar p i -> pure (Var p i)
|
H.ExpVar p i -> pure (Var p i)
|
||||||
|
|
||||||
declTo2pl :: H.Decl -> Process (Id, MonoT)
|
declTo2pl :: H.Decl -> Process (Id, MonoT)
|
||||||
|
|
45
src/Pretty.hs
Normal file
45
src/Pretty.hs
Normal file
|
@ -0,0 +1,45 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings, LambdaCase #-}
|
||||||
|
module Pretty (Pretty(..)) where
|
||||||
|
|
||||||
|
import Data.Text (Text)
|
||||||
|
|
||||||
|
import qualified Data.Set as S
|
||||||
|
import qualified Data.Map as M
|
||||||
|
|
||||||
|
import Type
|
||||||
|
import Data.List (sort)
|
||||||
|
import TC (initialState, apply, free)
|
||||||
|
|
||||||
|
class Pretty a where
|
||||||
|
pretty :: a -> Text
|
||||||
|
|
||||||
|
instance Pretty PolyT where
|
||||||
|
pretty t = case normalize t of
|
||||||
|
Forall s t -> "∀" <> foldMap (\(Id v) -> " " <> v) s <> ": " <> pretty t
|
||||||
|
Mono t -> pretty t
|
||||||
|
|
||||||
|
instance Pretty MonoT where
|
||||||
|
pretty = go . normalize
|
||||||
|
where
|
||||||
|
go = \case
|
||||||
|
TArr tl@TArr{} tr -> "(" <> go tl <> ") → " <> go tr
|
||||||
|
TArr tl tr -> go tl <> " → " <> go tr
|
||||||
|
TVar (Id i) -> i
|
||||||
|
TCon (Id i) -> i
|
||||||
|
|
||||||
|
class Normalize a where
|
||||||
|
normalize :: a -> a
|
||||||
|
|
||||||
|
instance Normalize PolyT where
|
||||||
|
normalize = \case
|
||||||
|
Forall i t -> Forall (S.fromList (snd <$> go t)) (normalize t)
|
||||||
|
t@Mono{} -> normalize t
|
||||||
|
|
||||||
|
instance Normalize MonoT where
|
||||||
|
normalize t = apply (goS t) t
|
||||||
|
|
||||||
|
go :: MonoT -> [(Id, Id)]
|
||||||
|
go t = zip (sort (S.toList (free t))) (variables initialState)
|
||||||
|
|
||||||
|
goS :: MonoT -> Subst
|
||||||
|
goS = M.fromList . map (\(x,y) -> (x, TVar y)) . go
|
52
src/TC.hs
52
src/TC.hs
|
@ -1,4 +1,5 @@
|
||||||
{-# LANGUAGE LambdaCase, TypeSynonymInstances, FlexibleInstances #-}
|
{-# LANGUAGE LambdaCase, TypeSynonymInstances #-}
|
||||||
|
{-# LANGUAGE TupleSections, FlexibleInstances #-}
|
||||||
module TC where
|
module TC where
|
||||||
|
|
||||||
import Control.Monad.Reader hiding (guard)
|
import Control.Monad.Reader hiding (guard)
|
||||||
|
@ -19,8 +20,8 @@ import Prelude hiding (map)
|
||||||
map :: Functor f => (a -> b) -> f a -> f b
|
map :: Functor f => (a -> b) -> f a -> f b
|
||||||
map = fmap
|
map = fmap
|
||||||
|
|
||||||
runCheck :: CheckState -> Check a -> Either TypeError a
|
runCheck :: CheckState -> Check a -> (Either TypeError a, CheckState)
|
||||||
runCheck s = fst . (flip runState) s . runExceptT . getCheck
|
runCheck s = (flip runState) s . runExceptT . getCheck
|
||||||
|
|
||||||
-- I'm still not quite sure how replicateM works, but in this instance it is
|
-- I'm still not quite sure how replicateM works, but in this instance it is
|
||||||
-- used to generate a list of strings "a", "b" ... "z", "aa", "ab" ... so on
|
-- used to generate a list of strings "a", "b" ... "z", "aa", "ab" ... so on
|
||||||
|
@ -44,6 +45,16 @@ setEnv env = get >>= \s -> put (CS (variables s) (lastPos s) env)
|
||||||
addEnv :: Id -> PolyT -> Check ()
|
addEnv :: Id -> PolyT -> Check ()
|
||||||
addEnv i p = getEnv >>= setEnv . M.insert i p
|
addEnv i p = getEnv >>= setEnv . M.insert i p
|
||||||
|
|
||||||
|
localEnv :: TypeEnv -> Check a -> Check a
|
||||||
|
localEnv e m = getEnv >>= \o -> setEnv e >> m >>= \r -> setEnv o >> pure r
|
||||||
|
|
||||||
|
localEnv' :: Check a -> Check a
|
||||||
|
localEnv' m = getEnv >>= \o -> m >>= \r -> setEnv o >> pure r
|
||||||
|
|
||||||
|
-- returns p again to allow chaining into lambdacase
|
||||||
|
setPos :: Positioned p => p -> Check p
|
||||||
|
setPos p = get >>= \s -> put (CS (variables s) (pos p) (typeEnv s)) >> pure p
|
||||||
|
|
||||||
guard :: Applicative f => f () -> Bool -> f ()
|
guard :: Applicative f => f () -> Bool -> f ()
|
||||||
guard _ True = pure ()
|
guard _ True = pure ()
|
||||||
guard f False = f
|
guard f False = f
|
||||||
|
@ -80,6 +91,9 @@ instance Substitutable a => Substitutable [a] where
|
||||||
apply = map . apply
|
apply = map . apply
|
||||||
free = foldMap free
|
free = foldMap free
|
||||||
|
|
||||||
|
applyEnv :: Subst -> Check ()
|
||||||
|
applyEnv s = getEnv >>= setEnv . apply s
|
||||||
|
|
||||||
-- This substution, and that one
|
-- This substution, and that one
|
||||||
(<&>) :: Subst -> Subst -> Subst
|
(<&>) :: Subst -> Subst -> Subst
|
||||||
(<&>) s1 s2 = map (apply s1) s2 <> s1
|
(<&>) s1 s2 = map (apply s1) s2 <> s1
|
||||||
|
@ -128,10 +142,36 @@ lookupType i = getEnv >>= \env ->
|
||||||
Nothing -> throwError (UnboundVariable i)
|
Nothing -> throwError (UnboundVariable i)
|
||||||
Just t -> instantiate t
|
Just t -> instantiate t
|
||||||
|
|
||||||
infer :: Exp -> Check MonoT
|
|
||||||
infer = undefined
|
|
||||||
|
|
||||||
constructs :: Id -> MonoT -> Bool
|
constructs :: Id -> MonoT -> Bool
|
||||||
constructs i (TArr _ t) = constructs i t
|
constructs i (TArr _ t) = constructs i t
|
||||||
constructs i1 (TCon i2) = i1 == i2
|
constructs i1 (TCon i2) = i1 == i2
|
||||||
constructs _ _ = False
|
constructs _ _ = False
|
||||||
|
|
||||||
|
infer :: Exp -> Check (Subst, MonoT)
|
||||||
|
infer = setPos >=> \case
|
||||||
|
Let _ [] e -> infer e
|
||||||
|
Let p ((i,e1):ies) e2 -> do
|
||||||
|
(s1, t1) <- infer e1
|
||||||
|
apply s1 <$> getEnv >>= \e -> localEnv e $ do
|
||||||
|
t1g <- generalize t1
|
||||||
|
addEnv i t1g
|
||||||
|
(s2, t2) <- infer (Let p ies e2)
|
||||||
|
pure (s2 <&> s1, t2)
|
||||||
|
|
||||||
|
Abs _ [] e -> infer e
|
||||||
|
Abs p (i:is) e -> localEnv' $ do
|
||||||
|
tv <- fresh
|
||||||
|
addEnv i (Forall S.empty tv)
|
||||||
|
(s, t) <- infer (Abs p is e)
|
||||||
|
pure (s, apply s tv `TArr` t)
|
||||||
|
|
||||||
|
App p e1 e2 -> localEnv' $ do
|
||||||
|
tv <- fresh
|
||||||
|
(s1, t1) <- infer e1
|
||||||
|
applyEnv s1
|
||||||
|
(s2, t2) <- infer e2
|
||||||
|
s3 <- unify (apply s2 t1) (TArr t2 tv)
|
||||||
|
return (s3 <&> s2 <&> s1, apply s3 tv)
|
||||||
|
App _ _ _ -> throwError Oop
|
||||||
|
|
||||||
|
Var _ i -> (emptySubst,) <$> lookupType i
|
||||||
|
|
41
src/Type.hs
41
src/Type.hs
|
@ -1,4 +1,5 @@
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase #-}
|
||||||
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
||||||
module Type
|
module Type
|
||||||
( module Type
|
( module Type
|
||||||
, Id(..)
|
, Id(..)
|
||||||
|
@ -14,6 +15,8 @@ import Data.Text (Text)
|
||||||
|
|
||||||
import Hm.Abs (Id(..))
|
import Hm.Abs (Id(..))
|
||||||
|
|
||||||
|
import qualified Hm.Abs as H (TypeSig'(..), TypeSig(..))
|
||||||
|
|
||||||
data PolyT
|
data PolyT
|
||||||
= Forall (Set Id) MonoT -- ^ ∀ σ₁ σ₂ … σₙ. τ
|
= Forall (Set Id) MonoT -- ^ ∀ σ₁ σ₂ … σₙ. τ
|
||||||
| Mono MonoT -- ^ τ
|
| Mono MonoT -- ^ τ
|
||||||
|
@ -32,14 +35,39 @@ type TL = TL' Pos
|
||||||
data TL' a
|
data TL' a
|
||||||
= TypeDef a Id [Id] TypeEnv -- ^ name, parameters, constructors and recursor
|
= TypeDef a Id [Id] TypeEnv -- ^ name, parameters, constructors and recursor
|
||||||
| VarDef a Id PolyT Exp -- ^ name, declared type, expression
|
| VarDef a Id PolyT Exp -- ^ name, declared type, expression
|
||||||
|
deriving Show
|
||||||
|
|
||||||
type Exp = Exp' Pos
|
type Exp = Exp' Pos
|
||||||
data Exp' a
|
data Exp' a
|
||||||
= Typed a Exp MonoT
|
= Let a [(Id,Exp)] Exp
|
||||||
| Let a [(Id, Exp)] Exp
|
|
||||||
| Abs a [Id] Exp
|
| Abs a [Id] Exp
|
||||||
| App a Exp [Exp]
|
| App a Exp Exp
|
||||||
| Var a Id
|
| Var a Id
|
||||||
|
deriving Show
|
||||||
|
|
||||||
|
class Positioned p where
|
||||||
|
pos :: p -> Pos
|
||||||
|
|
||||||
|
instance Positioned TL where
|
||||||
|
pos = \case
|
||||||
|
TypeDef p _ _ _ -> p
|
||||||
|
VarDef p _ _ _ -> p
|
||||||
|
|
||||||
|
instance Positioned Exp where
|
||||||
|
pos = \case
|
||||||
|
Let p _ _ -> p
|
||||||
|
Abs p _ _ -> p
|
||||||
|
App p _ _ -> p
|
||||||
|
Var p _ -> p
|
||||||
|
|
||||||
|
instance Positioned Pos where
|
||||||
|
pos = id
|
||||||
|
|
||||||
|
instance Positioned H.TypeSig where
|
||||||
|
pos = \case
|
||||||
|
H.TypeFun p _ _ -> p
|
||||||
|
H.TypeApp p _ _ -> p
|
||||||
|
H.TypeVar p _ -> p
|
||||||
|
|
||||||
data TypeError
|
data TypeError
|
||||||
= Oop -- ^ compiler error (oops)
|
= Oop -- ^ compiler error (oops)
|
||||||
|
@ -47,8 +75,9 @@ data TypeError
|
||||||
| InfiniteType Id MonoT
|
| InfiniteType Id MonoT
|
||||||
| UnboundVariable Id
|
| UnboundVariable Id
|
||||||
| Unimplemented Text
|
| Unimplemented Text
|
||||||
| InvalidTypeDecl Pos
|
| InvalidTypeDecl
|
||||||
| InvalidConstructor Pos
|
| InvalidConstructor
|
||||||
|
| ArityMismatch
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
type TypeEnv = Map Id PolyT
|
type TypeEnv = Map Id PolyT
|
||||||
|
|
Loading…
Reference in New Issue
Block a user