~jojo/Carth

a759c3ab6935ef35702fe263f9c8aac8bc97c202 — JoJo 2 years ago e31d502
Separate module SrcPos
5 files changed, 38 insertions(+), 29 deletions(-)

M src/Ast.hs
M src/Check.hs
M src/Parse.hs
A src/SrcPos.hs
M test/Arbitrary.hs
M src/Ast.hs => src/Ast.hs +1 -21
@@ 13,10 13,6 @@ module Ast
    , Pat(..)
    , Expr'(..)
    , Expr
    , WithPos(..)
    , unpos
    , getPos
    , onPosd
    , Def
    , ConstructorDefs(..)
    , TypeDef(..)


@@ 32,18 28,12 @@ import qualified Data.Map as Map
import Data.Map (Map)
import Data.List
import Control.Lens (makeLenses)
import Text.Megaparsec.Pos

import Misc
import SrcPos
import FreeVars
import NonEmpty

data WithPos a = WithPos SourcePos a

instance Show a => Show (WithPos a) where
    showsPrec p (WithPos _ a) = showsPrec p a
instance Eq a => Eq (WithPos a) where (WithPos _ a) == (WithPos _ b) = a == b

newtype Id =
    Id String
    deriving (Show, Eq, Ord)


@@ 173,7 163,6 @@ instance Pretty Scheme             where pretty' _ = prettyScheme
instance Pretty Type               where pretty' _ = prettyType
instance Pretty TPrim              where pretty' _ = prettyTPrim
instance Pretty TVar               where pretty' _ = prettyTVar
instance Pretty a => Pretty (WithPos a) where pretty' d = pretty' d . unpos

prettyProg :: Int -> Program -> String
prettyProg d (Program main defs tdefs) =


@@ 304,12 293,3 @@ prettyTVar :: TVar -> String
prettyTVar = \case
    TVExplicit (Id v) -> v
    TVImplicit n -> "#" ++ show n

onPosd :: (a -> b) -> WithPos a -> b
onPosd f = f . unpos

getPos :: WithPos a -> SourcePos
getPos (WithPos p _) = p

unpos :: WithPos a -> a
unpos (WithPos _ a) = a

M src/Check.hs => src/Check.hs +2 -4
@@ 18,13 18,11 @@ import Data.Maybe
import qualified Data.Set as Set
import Data.Set (Set)

import Text.Megaparsec.Pos (sourcePosPretty)

import Misc
import SrcPos
import FreeVars
import NonEmpty
import qualified Ast
import Ast (WithPos(..), unpos)
import AnnotAst

type TypeErr = String


@@ 181,7 179,7 @@ checkUserSchemes scms = forM_ scms check
            ++ pretty s2

infer :: Ast.Expr -> Infer (Type, Expr)
infer = Ast.onPosd $ \case
infer = onPosd $ \case
    Ast.Lit l -> pure (litType l, Lit l)
    Ast.Var x@(Ast.Id x') ->
        fmap (\t -> (t, Var (TypedVar x' t))) (lookupEnv x)

M src/Parse.hs => src/Parse.hs +1 -0
@@ 18,6 18,7 @@ import Data.Void
import Data.Composition

import Misc
import SrcPos
import Ast
import NonEmpty


A src/SrcPos.hs => src/SrcPos.hs +33 -0
@@ 0,0 1,33 @@
module SrcPos
    ( SourcePos(..)
    , WithPos(..)
    , onPosd
    , getPos
    , unpos
    , dummyPos
    , sourcePosPretty
    )
where

import Text.Megaparsec.Pos

import Misc

data WithPos a = WithPos SourcePos a

instance Show a => Show (WithPos a) where
    showsPrec p (WithPos _ a) = showsPrec p a
instance Eq a => Eq (WithPos a) where (WithPos _ a) == (WithPos _ b) = a == b
instance Pretty a => Pretty (WithPos a) where pretty' d = pretty' d . unpos

onPosd :: (a -> b) -> WithPos a -> b
onPosd f = f . unpos

getPos :: WithPos a -> SourcePos
getPos (WithPos p _) = p

unpos :: WithPos a -> a
unpos (WithPos _ a) = a

dummyPos :: SourcePos
dummyPos = initialPos "DUMMY"

M test/Arbitrary.hs => test/Arbitrary.hs +1 -4
@@ 8,8 8,8 @@ import qualified Data.Map as Map
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen
import Test.QuickCheck.Modifiers
import Text.Megaparsec.Pos

import SrcPos
import Parse
import Ast
import NonEmpty


@@ 49,9 49,6 @@ instance Arbitrary a => Arbitrary (NonEmpty a) where
    arbitrary = arbitraryNonEmpty
    shrink (x :| xs) = [x' :| xs' | (x', xs') <- shrink (x, xs)]

dummyPos :: SourcePos
dummyPos = initialPos "DUMMY"

arbitraryProgram :: Gen Program
arbitraryProgram = do
    main <- arbitrary