Skip to content
This repository has been archived by the owner on Nov 23, 2022. It is now read-only.

Commit

Permalink
Fix: Fix existing code to use AST.Intermediate
Browse files Browse the repository at this point in the history
  • Loading branch information
@coord-e
coord-e committed Nov 13, 2019
1 parent 8050380 commit 31f51d0
Show file tree
Hide file tree
Showing 15 changed files with 58 additions and 47 deletions.
4 changes: 2 additions & 2 deletions src/Compile.hs
View file
Expand Up @@ -4,7 +4,7 @@ import Config (Config, loadConfigFile,
loadDefaultConfigFile)
import qualified Emit (emit)
import qualified Overload (compile)
import qualified Parse (parse)
import qualified Parse (parseIntermediate)
import Reporting.Result (Result)

import Control.Monad ((<=<))
Expand All @@ -19,4 +19,4 @@ compileFile mconfig file = do
return $ flip compile content =<< config

compile :: Config -> Text -> Result String
compile c = fmap Emit.emit . Overload.compile c <=< Parse.parse
compile c = fmap Emit.emit . Overload.compile c <=< Parse.parseIntermediate
3 changes: 2 additions & 1 deletion src/Config.hs
View file
Expand Up @@ -3,7 +3,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Config where

import AST.Source hiding (type_)
import AST.Kind
import AST.Type hiding (type_)
import qualified Parse.Internal as P (Parser)
import Parse.Kind (kind)
import Parse.Type (typeScheme, type_)
Expand Down
4 changes: 3 additions & 1 deletion src/Overload.hs
View file
@@ -1,8 +1,10 @@
{-# LANGUAGE FlexibleContexts #-}
module Overload where

import qualified AST.Source as S
import qualified AST.Intermediate as S
import qualified AST.Kind as S
import qualified AST.Target as T
import qualified AST.Type as S
import Config
import Overload.Env
import Overload.GlobalInfer
Expand Down
11 changes: 5 additions & 6 deletions src/Overload/Env.hs
View file
@@ -1,8 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
module Overload.Env where

import qualified AST.Source as S
import qualified AST.Target as T
import AST.Name
import Config
import Overload.Kind
import Overload.Subst
Expand All @@ -16,9 +15,9 @@ import qualified Data.Set as Set


data Context
= Context { _overloads :: Map.Map S.Name TypeScheme
, _instantiations :: Map.Map S.Name [(TypeScheme, T.Name)]
, _bindings :: Map.Map S.Name TypeScheme }
= Context { _overloads :: Map.Map Name TypeScheme
, _instantiations :: Map.Map Name [(TypeScheme, Name)]
, _bindings :: Map.Map Name TypeScheme }

makeLenses ''Context

Expand All @@ -37,7 +36,7 @@ makeLenses ''Env

data Candidate
= Candidate { _id_ :: Int
, _name :: S.Name
, _name :: Name
, _type_ :: Type
, _savedContext :: Context }

Expand Down
2 changes: 1 addition & 1 deletion src/Overload/GlobalInfer.hs
View file
@@ -1,7 +1,7 @@
{-# LANGUAGE DataKinds #-}
module Overload.GlobalInfer where

import qualified AST.Source as S
import qualified AST.Intermediate as S
import qualified AST.Target as T
import Overload.Env
import Overload.Instance
Expand Down
4 changes: 2 additions & 2 deletions src/Overload/GlobalInfer.hs-boot
View file
@@ -1,7 +1,7 @@
{-# LANGUAGE DataKinds #-}
module Overload.GlobalInfer where

import qualified AST.Source as S
import qualified AST.Intermediate as S
import qualified AST.Target as T
import Overload.Env
import Overload.Type
Expand All @@ -15,4 +15,4 @@ import Control.Eff.State.Strict


processWaitList :: Type -> T.Expr -> WaitList -> Eff '[Fresh, Reader Env, State Constraints, Exc Error] (PredType, T.Expr)
globalInfer :: S.Expr -> Eff '[Fresh, Reader Env, State Constraints, Exc Error] (PredType, T.Expr)
globalInfer :: S.Expr -> Eff '[Fresh, Reader Env, State Constraints, Exc Error] (PredType, T.Expr)
7 changes: 3 additions & 4 deletions src/Overload/Instance.hs
View file
@@ -1,8 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
module Overload.Instance where

import qualified AST.Source as S
import qualified AST.Target as T
import AST.Name
import Overload.Env
import Overload.Internal
import Overload.Subst
Expand Down Expand Up @@ -37,15 +36,15 @@ isInstanceType t1 t2 = do
s@(Subst m) <- eitherToMaybe $ runUnifies t2 t1
toMaybe (disjointKeys m $ ftv t1) s

findInstantiation :: (Member (Exc Error) r, Member (Reader Env) r) => S.Name -> TypeScheme -> Eff r (Maybe (TypeScheme, T.Name))
findInstantiation :: (Member (Exc Error) r, Member (Reader Env) r) => Name -> TypeScheme -> Eff r (Maybe (TypeScheme, Name))
findInstantiation x s = check =<< mapM (filterM . views _1 $ isInstance s) =<< reader (views (context . instantiations) $ Map.lookup x)
where
check (Just [inst]) = return $ Just inst
check (Just []) = return Nothing
check (Just _) = throwError . TypeError $ OverlappingInstance x s
check Nothing = return Nothing

findInstantiationType :: (Member (Exc Error) r, Member (Reader Env) r) => S.Name -> Type -> Eff r (Maybe (TypeScheme, T.Name))
findInstantiationType :: (Member (Exc Error) r, Member (Reader Env) r) => Name -> Type -> Eff r (Maybe (TypeScheme, Name))
findInstantiationType x = findInstantiation x . scheme

canBeEliminated :: (Member (Exc Error) r, Member (Reader Env) r) => Constraint -> Eff r Bool
Expand Down
5 changes: 3 additions & 2 deletions src/Overload/Kind.hs
View file
Expand Up @@ -5,7 +5,8 @@
{-# LANGUAGE TypeFamilies #-}
module Overload.Kind where

import qualified AST.Source as S
import qualified AST.Kind as S
import AST.Name
import Data.Functor.Foldable
import Data.Functor.Foldable.TH
import Reporting.Report
Expand All @@ -22,7 +23,7 @@ data Kind
makeBaseFunctor ''Kind


type KindEnv = Map.Map S.TypeName Kind
type KindEnv = Map.Map TypeName Kind

initKindEnv :: KindEnv
initKindEnv = Map.empty
Expand Down
2 changes: 1 addition & 1 deletion src/Overload/KindInfer.hs
View file
@@ -1,7 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
module Overload.KindInfer where

import qualified AST.Source as S
import qualified AST.Type as S
import Overload.Env
import Overload.Kind
import Reporting.Error
Expand Down
16 changes: 9 additions & 7 deletions src/Overload/LocalInfer.hs
View file
Expand Up @@ -3,8 +3,10 @@
{-# LANGUAGE TupleSections #-}
module Overload.LocalInfer where

import qualified AST.Source as S
import qualified AST.Intermediate as S
import AST.Name
import qualified AST.Target as T
import qualified AST.Type as S
import Config (LiteralTypes (..))
import Overload.Env
import {-# SOURCE #-} Overload.GlobalInfer
Expand Down Expand Up @@ -110,7 +112,7 @@ resolvePredicates e (PredType cs t) = do
unify tx tc
return (T.App ae ex)

extractConstraint :: (Member (Exc Error) r, Member Fresh r, Member (Reader Env) r) => S.TypeScheme -> Eff r (S.Name, TypeScheme)
extractConstraint :: (Member (Exc Error) r, Member Fresh r, Member (Reader Env) r) => S.TypeScheme -> Eff r (Name, TypeScheme)
extractConstraint s@(S.Forall _ t) = do
kindTo t K.Constraint
SForall as (PredSem cs t') <- runSchemeEval s
Expand All @@ -121,16 +123,16 @@ extractConstraint s@(S.Forall _ t) = do
extract _ = error "something went wrong in kinding"


withInstance :: Member (Reader Env) r => S.Name -> (TypeScheme, T.Name) -> Eff r a -> Eff r a
withInstance :: Member (Reader Env) r => Name -> (TypeScheme, Name) -> Eff r a -> Eff r a
withInstance x i = local (over (context . instantiations) (adjustWithDefault (i:) [i] x))

withBinding :: Member (Reader Env) r => S.Name -> TypeScheme -> Eff r a -> Eff r a
withBinding :: Member (Reader Env) r => Name -> TypeScheme -> Eff r a -> Eff r a
withBinding x s = local (over (context . bindings) (Map.insert x s))

withBindingType :: Member (Reader Env) r => S.Name -> Type -> Eff r a -> Eff r a
withBindingType :: Member (Reader Env) r => Name -> Type -> Eff r a -> Eff r a
withBindingType x = withBinding x . scheme

withOverload :: Member (Reader Env) r => S.Name -> TypeScheme -> Eff r a -> Eff r a
withOverload :: Member (Reader Env) r => Name -> TypeScheme -> Eff r a -> Eff r a
withOverload x t = local (over (context . overloads) (Map.insert x t))

literalType :: (Member (Exc Error) r, Member (Reader Env) r, Member Fresh r) => (LiteralTypes -> S.Type) -> Eff r Type
Expand All @@ -141,7 +143,7 @@ literalType f = do
PredType cs t' <- runEvalToType t
assert (null cs) $ return t'

freshn :: Member Fresh r => String -> Eff r T.Name
freshn :: Member Fresh r => String -> Eff r Name
freshn base = do
v <- fresh
return (base ++ "_" ++ show v)
9 changes: 5 additions & 4 deletions src/Overload/Type.hs
View file
Expand Up @@ -7,7 +7,8 @@
{-# LANGUAGE TypeFamilies #-}
module Overload.Type where

import qualified AST.Source as S
import AST.Name
import qualified AST.Type as S
import Reporting.Report

import Control.Lens.TH
Expand All @@ -33,7 +34,7 @@ makeBaseFunctor ''Type

-- normalized type (Constraint kind)
data Constraint
= Constraint { _name :: S.TypeName
= Constraint { _name :: TypeName
, _requirement :: Type }
deriving (Show, Eq)

Expand All @@ -58,7 +59,7 @@ scheme :: Type -> TypeScheme
scheme = Forall [] . PredType []


type TypeEnv = Map.Map S.TypeName PredSem
type TypeEnv = Map.Map TypeName PredSem

initTypeEnv :: TypeEnv
initTypeEnv = Map.empty
Expand All @@ -67,7 +68,7 @@ initTypeEnv = Map.empty
data Sem
= SType Type
| SConstraint Constraint
| SClosure S.TypeName S.Type TypeEnv
| SClosure TypeName S.Type TypeEnv

data PredSem
= PredSem { _constraintsS :: [Constraint]
Expand Down
7 changes: 4 additions & 3 deletions src/Overload/TypeEval.hs
View file
Expand Up @@ -2,7 +2,8 @@
{-# LANGUAGE TemplateHaskell #-}
module Overload.TypeEval where

import qualified AST.Source as S
import AST.Name
import qualified AST.Type as S
import Overload.Env
import Overload.Type
import Overload.Var
Expand All @@ -15,7 +16,7 @@ import Control.Lens
import qualified Data.Map as Map


type TyVarEnv = Map.Map S.TVarName TyVar
type TyVarEnv = Map.Map TVarName TyVar

data TypeEvalEnv
= TypeEvalEnv { _typeEnv_ :: TypeEnv
Expand Down Expand Up @@ -47,7 +48,7 @@ expectTy :: Sem -> Type
expectTy (SType t) = t
expectTy _ = error "a type is expected; invalid kind"

expectClos :: Sem -> (S.TypeName, S.Type, TypeEnv)
expectClos :: Sem -> (TypeName, S.Type, TypeEnv)
expectClos (SClosure x t env) = (x, t, env)
expectClos _ = error "an abstraction is expected; invalid kind"

Expand Down
15 changes: 10 additions & 5 deletions src/Parse.hs
View file
@@ -1,14 +1,19 @@
module Parse where

import AST.Source
import Parse.Expr
import qualified AST.Intermediate as IAST
import qualified AST.Source as SAST
import qualified Parse.Intermediate as I
import qualified Parse.Source as S
import Reporting.Error
import Reporting.Result

import Data.Bifunctor
import Data.Text
import qualified Text.Megaparsec as M
import qualified Text.Megaparsec as M


parse :: Text -> Result Expr
parse = first (ParseError . M.errorBundlePretty) . M.parse expr "input"
parseIntermediate :: Text -> Result IAST.Expr
parseIntermediate = first (ParseError . M.errorBundlePretty) . M.parse I.expr "input"

parseSource :: Text -> Result SAST.Expr
parseSource = first (ParseError . M.errorBundlePretty) . M.parse S.expr "input"
4 changes: 2 additions & 2 deletions src/Reporting/Error/Kind.hs
View file
@@ -1,14 +1,14 @@
module Reporting.Error.Kind where

import qualified AST.Source as S
import AST.Name
import Overload.Kind
import Reporting.Report


data KindError
= UnificationFail Kind Kind
| UnableToApply Kind Kind
| UnboundName S.TypeName
| UnboundName TypeName
deriving Show


Expand Down
12 changes: 6 additions & 6 deletions src/Reporting/Error/Type.hs
View file
@@ -1,6 +1,6 @@
module Reporting.Error.Type where

import qualified AST.Source as S
import AST.Name
import Data.List (intercalate)
import Overload.Type
import Reporting.Report
Expand All @@ -9,12 +9,12 @@ import Reporting.Report
data TypeError
= UnificationFail Type Type
| InfiniteType TyVar Type
| UnableToInstantiate S.Name TypeScheme TypeScheme
| InvalidInstance S.Name TypeScheme TypeScheme
| OverlappingInstance S.Name TypeScheme
| NotOverloadedInstance S.Name
| UnableToInstantiate Name TypeScheme TypeScheme
| InvalidInstance Name TypeScheme TypeScheme
| OverlappingInstance Name TypeScheme
| NotOverloadedInstance Name
| UnresolvedVariable [Constraint]
| UnboundVariable S.Name
| UnboundVariable Name
deriving Show


Expand Down

0 comments on commit 31f51d0

Please sign in to comment.