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