Add Slice class

examples/string-pats.hs

@@ -1,3 +1,4 @@
-main = case "foo" of
-         "bar" -> 0
-         "foo" -> 1
+main =
+  case "foo" of
+    "bar" -> 0
+    "foo" -> 1

examples/string-substring.hs

@@ -0,0 +1 @@
+main = take 2 (drop 7 "Hello, World!")

src/Duet/Printer.hs

@@ -72,6 +72,8 @@ printPrimop =
     PrimopRationalPlus -> "plus"
     PrimopRationalDivide -> "divide"
     PrimopStringAppend -> "append"
+    PrimopStringDrop -> "drop"
+    PrimopStringTake -> "take"
 
 instance Printable Identifier where
   printit _ =

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

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)

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.

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)
+                       }
+                   ]))))