diff --git a/src/Core/HindleyMilner.hs b/src/Core/HindleyMilner.hs index 3699310..cf0dace 100644 --- a/src/Core/HindleyMilner.hs +++ b/src/Core/HindleyMilner.hs @@ -55,11 +55,14 @@ instance IsRlpcError TypeError where liftRlpcError = \case -- todo: use anti-parser instead of show TyErrCouldNotUnify t u -> Text - [ T.pack $ printf "Could not match type `%s' with `%s'." + [ T.pack $ printf "Could not match type `%s` with `%s`." (show t) (show u) , "Expected: " <> tshow t , "Got: " <> tshow u ] + TyErrUntypedVariable n -> Text + [ "Untyped (likely undefined) variable `" <> n <> "`" + ] TyErrRecursiveType t x -> Text [ T.pack $ printf "recursive type error lol" ] @@ -157,7 +160,12 @@ gather = \g e -> runStateT (go g e) ([],0) <&> \ (t,(cs,_)) -> (t,cs) where Let Rec bs e -> do g' <- buildLetrecContext g bs go g' e - + Lam bs e -> case bs of + [x] -> do + tx <- uniqueVar + let g' = (x,tx) : g + te <- go g' e + pure (tx :-> te) -- TODO lambda, case buildLetrecContext :: Context' -> [Binding'] diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index fb9b720..f4785c6 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -5,6 +5,7 @@ Description : Core ASTs and the like {-# LANGUAGE PatternSynonyms, OverloadedStrings #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DerivingStrategies, DerivingVia #-} module Core.Syntax ( Expr(..) , Type(..) @@ -45,6 +46,7 @@ import Data.HashMap.Strict qualified as H import Data.Hashable import Data.Text qualified as T import Data.Char +import GHC.Generics -- Lift instances for the Core quasiquoters import Language.Haskell.TH.Syntax (Lift) import Lens.Micro.TH (makeLenses) @@ -127,7 +129,9 @@ data Program b = Program { _programScDefs :: [ScDef b] , _programTypeSigs :: H.HashMap b Type } - deriving (Show, Lift) + deriving (Show, Lift, Generic) + deriving (Semigroup, Monoid) + via Generically (Program b) makeLenses ''Program pure [] @@ -148,11 +152,12 @@ instance IsString Type where | otherwise = TyVar . fromString $ s where (c:_) = s -instance (Hashable b) => Semigroup (Program b) where - (<>) = undefined +-- instance (Hashable b) => Semigroup (Program b) where +-- p <> q = Program +-- { _programScDefs = _programScDefs p <> _programScDefs q } -instance (Hashable b) => Monoid (Program b) where - mempty = Program mempty mempty +-- instance (Hashable b) => Monoid (Program b) where +-- mempty = Program mempty mempty ----------------------------------------------------------------------------------