mirror of
https://github.com/chrisdone/duet.git
synced 2024-08-16 07:40:39 +03:00
Add Slice class
This commit is contained in:
parent
8c3eb90c3d
commit
dc886419fd
@ -1,3 +1,4 @@
|
|||||||
main = case "foo" of
|
main =
|
||||||
"bar" -> 0
|
case "foo" of
|
||||||
"foo" -> 1
|
"bar" -> 0
|
||||||
|
"foo" -> 1
|
||||||
|
1
examples/string-substring.hs
Normal file
1
examples/string-substring.hs
Normal file
@ -0,0 +1 @@
|
|||||||
|
main = take 2 (drop 7 "Hello, World!")
|
@ -72,6 +72,8 @@ printPrimop =
|
|||||||
PrimopRationalPlus -> "plus"
|
PrimopRationalPlus -> "plus"
|
||||||
PrimopRationalDivide -> "divide"
|
PrimopRationalDivide -> "divide"
|
||||||
PrimopStringAppend -> "append"
|
PrimopStringAppend -> "append"
|
||||||
|
PrimopStringDrop -> "drop"
|
||||||
|
PrimopStringTake -> "take"
|
||||||
|
|
||||||
instance Printable Identifier where
|
instance Printable Identifier where
|
||||||
printit _ =
|
printit _ =
|
||||||
|
@ -50,17 +50,18 @@ setupEnv env typeMakers = do
|
|||||||
(FunctionKind StarKind (FunctionKind StarKind StarKind)))
|
(FunctionKind StarKind (FunctionKind StarKind StarKind)))
|
||||||
let specialTypes =
|
let specialTypes =
|
||||||
(SpecialTypes
|
(SpecialTypes
|
||||||
{ specialTypesBool = boolDataType
|
{ specialTypesBool = boolDataType
|
||||||
, specialTypesChar = TypeConstructor theChar StarKind
|
, specialTypesChar = TypeConstructor theChar StarKind
|
||||||
, specialTypesString = TypeConstructor theString StarKind
|
, specialTypesString = TypeConstructor theString StarKind
|
||||||
, specialTypesFunction = function
|
, specialTypesFunction = function
|
||||||
, specialTypesInteger = TypeConstructor theInteger StarKind
|
, specialTypesInteger = TypeConstructor theInteger StarKind
|
||||||
, specialTypesRational = TypeConstructor theRational StarKind
|
, specialTypesRational = TypeConstructor theRational StarKind
|
||||||
})
|
})
|
||||||
(numClass, plus, times) <- makeNumClass function
|
(numClass, plus, times) <- makeNumClass function
|
||||||
(negClass, subtract') <- makeNegClass function
|
(negClass, subtract') <- makeNegClass function
|
||||||
(fracClass, divide) <- makeFracClass function
|
(fracClass, divide) <- makeFracClass function
|
||||||
(monoidClass) <- makeMonoidClass function
|
(monoidClass) <- makeMonoidClass function
|
||||||
|
(sliceClass) <- makeSliceClass (specialTypesInteger specialTypes) function
|
||||||
boolSigs <- dataTypeSignatures specialTypes boolDataType
|
boolSigs <- dataTypeSignatures specialTypes boolDataType
|
||||||
typesSigs <-
|
typesSigs <-
|
||||||
fmap
|
fmap
|
||||||
@ -70,19 +71,38 @@ setupEnv env typeMakers = do
|
|||||||
classSigs <-
|
classSigs <-
|
||||||
fmap
|
fmap
|
||||||
concat
|
concat
|
||||||
(mapM classSignatures [numClass, negClass, fracClass, monoidClass])
|
(mapM classSignatures [numClass, negClass, fracClass, monoidClass, sliceClass])
|
||||||
primopSigs <- makePrimOps specialTypes
|
primopSigs <- makePrimOps specialTypes
|
||||||
let signatures = boolSigs <> classSigs <> primopSigs <> typesSigs
|
let signatures = boolSigs <> classSigs <> primopSigs <> typesSigs
|
||||||
specialSigs =
|
specialSigs =
|
||||||
SpecialSigs
|
SpecialSigs
|
||||||
{ specialSigsTrue = true
|
{ specialSigsTrue = true
|
||||||
, specialSigsFalse = false
|
, specialSigsFalse = false
|
||||||
, specialSigsPlus = plus
|
, specialSigsPlus = plus
|
||||||
, specialSigsSubtract = subtract'
|
, specialSigsSubtract = subtract'
|
||||||
, specialSigsTimes = times
|
, specialSigsTimes = times
|
||||||
, specialSigsDivide = divide
|
, specialSigsDivide = divide
|
||||||
}
|
}
|
||||||
specials = Specials specialSigs specialTypes
|
specials = Specials specialSigs specialTypes
|
||||||
|
stringSlice <-
|
||||||
|
makeInst
|
||||||
|
specials
|
||||||
|
(IsIn
|
||||||
|
(className sliceClass)
|
||||||
|
[ConstructorType (specialTypesString specialTypes)])
|
||||||
|
[ ( "take"
|
||||||
|
, ( ()
|
||||||
|
, Alternative
|
||||||
|
()
|
||||||
|
[]
|
||||||
|
(VariableExpression () (PrimopName PrimopStringTake))))
|
||||||
|
, ( "drop"
|
||||||
|
, ( ()
|
||||||
|
, Alternative
|
||||||
|
()
|
||||||
|
[]
|
||||||
|
(VariableExpression () (PrimopName PrimopStringDrop))))
|
||||||
|
]
|
||||||
stringMonoid <-
|
stringMonoid <-
|
||||||
makeInst
|
makeInst
|
||||||
specials
|
specials
|
||||||
@ -181,19 +201,21 @@ setupEnv env typeMakers = do
|
|||||||
addClass negClass >=>
|
addClass negClass >=>
|
||||||
addClass fracClass >=>
|
addClass fracClass >=>
|
||||||
addClass monoidClass >=>
|
addClass monoidClass >=>
|
||||||
|
addClass sliceClass >=>
|
||||||
addInstance numInt >=>
|
addInstance numInt >=>
|
||||||
addInstance negInt >=>
|
addInstance negInt >=>
|
||||||
addInstance stringMonoid >=>
|
addInstance stringMonoid >=>
|
||||||
|
addInstance stringSlice >=>
|
||||||
addInstance fracRational >=>
|
addInstance fracRational >=>
|
||||||
addInstance negRational >=> addInstance numRational
|
addInstance negRational >=> addInstance numRational
|
||||||
in update env
|
in update env
|
||||||
pure
|
pure
|
||||||
Builtins
|
Builtins
|
||||||
{ builtinsSpecialSigs = specialSigs
|
{ builtinsSpecialSigs = specialSigs
|
||||||
, builtinsSpecialTypes = specialTypes
|
, builtinsSpecialTypes = specialTypes
|
||||||
, builtinsSignatures = signatures
|
, builtinsSignatures = signatures
|
||||||
, builtinsTypeClasses = env'
|
, builtinsTypeClasses = env'
|
||||||
}
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Builtin classes and primops
|
-- Builtin classes and primops
|
||||||
@ -236,7 +258,15 @@ makePrimOps SpecialTypes {..} = do
|
|||||||
PrimopStringAppend ->
|
PrimopStringAppend ->
|
||||||
TypeSignature
|
TypeSignature
|
||||||
(PrimopName PrimopStringAppend)
|
(PrimopName PrimopStringAppend)
|
||||||
(toScheme (string --> string --> string))))
|
(toScheme (string --> string --> string))
|
||||||
|
PrimopStringTake ->
|
||||||
|
TypeSignature
|
||||||
|
(PrimopName PrimopStringTake)
|
||||||
|
(toScheme (integer --> string --> string))
|
||||||
|
PrimopStringDrop ->
|
||||||
|
TypeSignature
|
||||||
|
(PrimopName PrimopStringDrop)
|
||||||
|
(toScheme (integer --> string --> string))))
|
||||||
[minBound .. maxBound]
|
[minBound .. maxBound]
|
||||||
pure sigs
|
pure sigs
|
||||||
where
|
where
|
||||||
@ -327,3 +357,22 @@ makeMonoidClass function = do
|
|||||||
infixr 1 -->
|
infixr 1 -->
|
||||||
(-->) :: Type Name -> Type Name -> Type Name
|
(-->) :: Type Name -> Type Name -> Type Name
|
||||||
a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b
|
a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b
|
||||||
|
|
||||||
|
makeSliceClass :: MonadSupply Int m => TypeConstructor Name -> TypeConstructor Name -> m (Class Type Name l)
|
||||||
|
makeSliceClass integer' function = do
|
||||||
|
a <- fmap (\n -> TypeVariable n StarKind) (supplyTypeName "a")
|
||||||
|
let a' = VariableType a
|
||||||
|
drop' <- supplyMethodName "drop"
|
||||||
|
take' <- supplyMethodName "take"
|
||||||
|
cls <-
|
||||||
|
makeClass
|
||||||
|
"Slice"
|
||||||
|
[a]
|
||||||
|
[ (drop', Forall [a] (Qualified [] (ConstructorType integer' --> (a' --> a'))))
|
||||||
|
, (take', Forall [a] (Qualified [] (ConstructorType integer' --> (a' --> a'))))
|
||||||
|
]
|
||||||
|
pure cls
|
||||||
|
where
|
||||||
|
infixr 1 -->
|
||||||
|
(-->) :: Type Name -> Type Name -> Type Name
|
||||||
|
a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b
|
||||||
|
@ -100,6 +100,19 @@ expandWhnf typeClassEnv specialSigs signatures e b = go e
|
|||||||
y' <- go y
|
y' <- go y
|
||||||
pure
|
pure
|
||||||
(ApplicationExpression l (ApplicationExpression l1 op x) y')
|
(ApplicationExpression l (ApplicationExpression l1 op x) y')
|
||||||
|
LiteralExpression _ (IntegerLiteral n) ->
|
||||||
|
case y of
|
||||||
|
LiteralExpression _ (StringLiteral sy) ->
|
||||||
|
case primop of
|
||||||
|
PrimopStringTake ->
|
||||||
|
pure (LiteralExpression l (StringLiteral (genericTake n sy)))
|
||||||
|
PrimopStringDrop ->
|
||||||
|
pure (LiteralExpression l (StringLiteral (genericDrop n sy)))
|
||||||
|
_ -> error "Runtime type error that should not occurr"
|
||||||
|
_ -> do
|
||||||
|
y' <- go y
|
||||||
|
pure
|
||||||
|
(ApplicationExpression l (ApplicationExpression l1 op x) y')
|
||||||
_ -> do
|
_ -> do
|
||||||
x' <- go x
|
x' <- go x
|
||||||
pure (ApplicationExpression l (ApplicationExpression l1 op x') y)
|
pure (ApplicationExpression l (ApplicationExpression l1 op x') y)
|
||||||
|
@ -167,6 +167,8 @@ data Primop
|
|||||||
| PrimopRationalSubtract
|
| PrimopRationalSubtract
|
||||||
| PrimopRationalTimes
|
| PrimopRationalTimes
|
||||||
| PrimopStringAppend
|
| PrimopStringAppend
|
||||||
|
| PrimopStringDrop
|
||||||
|
| PrimopStringTake
|
||||||
deriving (Show, Generic, Data, Typeable, Eq, Ord, Enum, Bounded)
|
deriving (Show, Generic, Data, Typeable, Eq, Ord, Enum, Bounded)
|
||||||
|
|
||||||
-- | State of inferring.
|
-- | State of inferring.
|
||||||
|
24
test/Spec.hs
24
test/Spec.hs
@ -70,9 +70,9 @@ spec =
|
|||||||
(Alternative
|
(Alternative
|
||||||
{ alternativeLabel = ()
|
{ alternativeLabel = ()
|
||||||
, alternativePatterns =
|
, alternativePatterns =
|
||||||
[VariablePattern () (ValueName 42 "x")]
|
[VariablePattern () (ValueName 49 "x")]
|
||||||
, alternativeExpression =
|
, alternativeExpression =
|
||||||
VariableExpression () (ValueName 42 "x")
|
VariableExpression () (ValueName 49 "x")
|
||||||
}))
|
}))
|
||||||
(LiteralExpression () (IntegerLiteral 1))
|
(LiteralExpression () (IntegerLiteral 1))
|
||||||
, LiteralExpression () (IntegerLiteral 1)
|
, LiteralExpression () (IntegerLiteral 1)
|
||||||
@ -106,13 +106,13 @@ spec =
|
|||||||
pure things)
|
pure things)
|
||||||
[1 ..])))))
|
[1 ..])))))
|
||||||
(Right
|
(Right
|
||||||
((CaseExpression
|
(CaseExpression
|
||||||
()
|
()
|
||||||
(VariableExpression () (ValueName 42 "loop"))
|
(VariableExpression () (ValueName 49 "loop"))
|
||||||
[ CaseAlt
|
[ CaseAlt
|
||||||
{ caseAltLabel = ()
|
{ caseAltLabel = ()
|
||||||
, caseAltPattern = BangPattern (WildcardPattern () "_")
|
, caseAltPattern = BangPattern (WildcardPattern () "_")
|
||||||
, caseAltExpression =
|
, caseAltExpression =
|
||||||
LiteralExpression () (IntegerLiteral 1)
|
LiteralExpression () (IntegerLiteral 1)
|
||||||
}
|
}
|
||||||
])))))
|
]))))
|
||||||
|
Loading…
Reference in New Issue
Block a user