diff --git a/examples/string-pats.hs b/examples/string-pats.hs index 9579b69..5b3ef19 100644 --- a/examples/string-pats.hs +++ b/examples/string-pats.hs @@ -1,3 +1,4 @@ -main = case "foo" of - "bar" -> 0 - "foo" -> 1 +main = + case "foo" of + "bar" -> 0 + "foo" -> 1 diff --git a/examples/string-substring.hs b/examples/string-substring.hs new file mode 100644 index 0000000..e15f7c1 --- /dev/null +++ b/examples/string-substring.hs @@ -0,0 +1 @@ +main = take 2 (drop 7 "Hello, World!") diff --git a/src/Duet/Printer.hs b/src/Duet/Printer.hs index 73fc67a..8d2ffd2 100644 --- a/src/Duet/Printer.hs +++ b/src/Duet/Printer.hs @@ -72,6 +72,8 @@ printPrimop = PrimopRationalPlus -> "plus" PrimopRationalDivide -> "divide" PrimopStringAppend -> "append" + PrimopStringDrop -> "drop" + PrimopStringTake -> "take" instance Printable Identifier where printit _ = diff --git a/src/Duet/Setup.hs b/src/Duet/Setup.hs index db2ccf9..84af46e 100644 --- a/src/Duet/Setup.hs +++ b/src/Duet/Setup.hs @@ -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 diff --git a/src/Duet/Stepper.hs b/src/Duet/Stepper.hs index 4477913..94a8eb4 100644 --- a/src/Duet/Stepper.hs +++ b/src/Duet/Stepper.hs @@ -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) diff --git a/src/Duet/Types.hs b/src/Duet/Types.hs index ee08915..fd182df 100644 --- a/src/Duet/Types.hs +++ b/src/Duet/Types.hs @@ -167,6 +167,8 @@ data Primop | PrimopRationalSubtract | PrimopRationalTimes | PrimopStringAppend + | PrimopStringDrop + | PrimopStringTake deriving (Show, Generic, Data, Typeable, Eq, Ord, Enum, Bounded) -- | State of inferring. diff --git a/test/Spec.hs b/test/Spec.hs index 1d23e44..df6c6f4 100644 --- a/test/Spec.hs +++ b/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) + } + ]))))