Skip to content

C
capnproto
Commit f0877237 authored by Kenton Varda's avatar Kenton Varda
Browse files
Options

Bunch of little things.

parent 2e3f671c
Hide whitespace changes
Inline Side-by-side
Showing with 235 additions and 50 deletions
compiler/capnproto-compiler.cabal
View file @ f0877237
......@@ -19,5 +19,6 @@ executable capnproto-compiler
Grammar,
Parser,
Compiler,
Semantics
Semantics,
Util
compiler/src/Compiler.hs
View file @ f0877237
......@@ -28,6 +28,8 @@ import Semantics
import Token(Located(Located))
import Parser(parseFile)
import qualified Data.Map as Map
import qualified Data.List as List
import Data.Maybe(mapMaybe)
import Text.Parsec.Pos(SourcePos, newPos)
import Text.Parsec.Error(ParseError, newErrorMessage, Message(Message, Expect))
import Text.Printf(printf)
......@@ -98,6 +100,8 @@ feedback f = status where
statusToMaybe (Active x _) = Just x
statusToMaybe (Failed _) = Nothing
doAll statuses = Active [x | (Active x _) <- statuses] (concatMap statusErrors statuses)
------------------------------------------------------------------------------------------
-- Symbol lookup
------------------------------------------------------------------------------------------
......@@ -150,30 +154,48 @@ builtinTypeMap = Map.fromList
------------------------------------------------------------------------------------------
fromIntegerChecked :: Integral a => SourcePos -> Integer -> Status a
fromIntegerChecked pos x = result where
fromIntegerChecked :: Integral a => String -> SourcePos -> Integer -> Status a
fromIntegerChecked name pos x = result where
unchecked = fromInteger x
result = if toInteger unchecked == x
then succeed unchecked
else makeError pos "Integer out of range for type."
else makeError pos (printf "Integer %d out of range for type %s." x name)
compileValue :: SourcePos -> TypeDesc -> FieldValue -> Status ValueDesc
compileValue _ (BuiltinType BuiltinVoid) VoidFieldValue = succeed VoidDesc
compileValue _ (BuiltinType BuiltinBool) (BoolFieldValue x) = succeed (BoolDesc x)
compileValue pos (BuiltinType BuiltinInt8) (IntegerFieldValue x) = fmap Int8Desc (fromIntegerChecked pos x)
compileValue pos (BuiltinType BuiltinInt16) (IntegerFieldValue x) = fmap Int16Desc (fromIntegerChecked pos x)
compileValue pos (BuiltinType BuiltinInt32) (IntegerFieldValue x) = fmap Int32Desc (fromIntegerChecked pos x)
compileValue pos (BuiltinType BuiltinInt64) (IntegerFieldValue x) = fmap Int64Desc (fromIntegerChecked pos x)
compileValue pos (BuiltinType BuiltinUInt8) (IntegerFieldValue x) = fmap UInt8Desc (fromIntegerChecked pos x)
compileValue pos (BuiltinType BuiltinUInt16) (IntegerFieldValue x) = fmap UInt16Desc (fromIntegerChecked pos x)
compileValue pos (BuiltinType BuiltinUInt32) (IntegerFieldValue x) = fmap UInt32Desc (fromIntegerChecked pos x)
compileValue pos (BuiltinType BuiltinUInt64) (IntegerFieldValue x) = fmap UInt64Desc (fromIntegerChecked pos x)
compileValue pos (BuiltinType BuiltinInt8 ) (IntegerFieldValue x) = fmap Int8Desc (fromIntegerChecked "Int8" pos x)
compileValue pos (BuiltinType BuiltinInt16 ) (IntegerFieldValue x) = fmap Int16Desc (fromIntegerChecked "Int16" pos x)
compileValue pos (BuiltinType BuiltinInt32 ) (IntegerFieldValue x) = fmap Int32Desc (fromIntegerChecked "Int32" pos x)
compileValue pos (BuiltinType BuiltinInt64 ) (IntegerFieldValue x) = fmap Int64Desc (fromIntegerChecked "Int64" pos x)
compileValue pos (BuiltinType BuiltinUInt8 ) (IntegerFieldValue x) = fmap UInt8Desc (fromIntegerChecked "UInt8" pos x)
compileValue pos (BuiltinType BuiltinUInt16) (IntegerFieldValue x) = fmap UInt16Desc (fromIntegerChecked "UInt16" pos x)
compileValue pos (BuiltinType BuiltinUInt32) (IntegerFieldValue x) = fmap UInt32Desc (fromIntegerChecked "UInt32" pos x)
compileValue pos (BuiltinType BuiltinUInt64) (IntegerFieldValue x) = fmap UInt64Desc (fromIntegerChecked "UInt64" pos x)
compileValue _ (BuiltinType BuiltinFloat32) (FloatFieldValue x) = succeed (Float32Desc (realToFrac x))
compileValue _ (BuiltinType BuiltinFloat64) (FloatFieldValue x) = succeed (Float64Desc x)
compileValue _ (BuiltinType BuiltinFloat32) (IntegerFieldValue x) = succeed (Float32Desc (realToFrac x))
compileValue _ (BuiltinType BuiltinFloat64) (IntegerFieldValue x) = succeed (Float64Desc (realToFrac x))
compileValue _ (BuiltinType BuiltinText) (StringFieldValue x) = succeed (TextDesc x)
compileValue _ (BuiltinType BuiltinBytes) (StringFieldValue x) =
succeed (BytesDesc (map (fromIntegral . fromEnum) x))
compileValue _ (BuiltinType BuiltinData) (StringFieldValue x) =
succeed (DataDesc (map (fromIntegral . fromEnum) x))
compileValue pos (EnumType desc) (IdentifierFieldValue name) =
case lookupMember name (enumMemberMap desc) of
Just (DescEnumValue value) -> succeed (EnumValueValueDesc value)
_ -> makeError pos (printf "Enum type %s has no value %s." (enumName desc) name)
compileValue _ (StructType desc) (RecordFieldValue fields) = result where
result = fmap StructValueDesc (doAll (map compileFieldAssignment fields))
compileFieldAssignment :: (Located String, Located FieldValue) -> Status (FieldDesc, ValueDesc)
compileFieldAssignment (Located namePos name, Located valPos val) =
case lookupMember name (structMemberMap desc) of
Just (DescField field) ->
fmap (\x -> (field, x)) (compileValue valPos (fieldType field) val)
_ -> makeError namePos (printf "Struct %s has no field %s." (structName desc) name)
compileValue _ (ListType t) (ListFieldValue l) =
fmap ListDesc (doAll [ compileValue vpos t v | Located vpos v <- l ])
compileValue pos (BuiltinType BuiltinVoid) _ = makeError pos "Void fields cannot have values."
compileValue pos (BuiltinType BuiltinBool) _ = makeExpectError pos "boolean"
......@@ -188,12 +210,12 @@ compileValue pos (BuiltinType BuiltinUInt64) _ = makeExpectError pos "integer"
compileValue pos (BuiltinType BuiltinFloat32) _ = makeExpectError pos "number"
compileValue pos (BuiltinType BuiltinFloat64) _ = makeExpectError pos "number"
compileValue pos (BuiltinType BuiltinText) _ = makeExpectError pos "string"
compileValue pos (BuiltinType BuiltinBytes) _ = makeExpectError pos "string"
compileValue pos (BuiltinType BuiltinData) _ = makeExpectError pos "string"
compileValue pos (EnumType _) _ = makeError pos "Unimplemented: enum default values"
compileValue pos (StructType _) _ = makeError pos "Unimplemented: struct default values"
compileValue pos (EnumType _) _ = makeExpectError pos "enum value name"
compileValue pos (StructType _) _ = makeExpectError pos "parenthesized list of field assignments"
compileValue pos (InterfaceType _) _ = makeError pos "Interfaces can't have default values."
compileValue pos (ListType _) _ = makeError pos "Unimplemented: array default values"
compileValue pos (ListType _) _ = makeExpectError pos "list"
makeFileMemberMap :: FileDesc -> Map.Map String Desc
makeFileMemberMap desc = Map.fromList allMembers where
......@@ -226,6 +248,47 @@ compileType scope (TypeExpression n (param:moreParams)) = do
else makeError (declNamePos n) "'List' requires exactly one type parameter."
_ -> makeError (declNamePos n) "Only the type 'List' can have type parameters."
------------------------------------------------------------------------------------------
requireSequentialNumbering :: String -> [Located Integer] -> Status ()
requireSequentialNumbering kind items = Active () (loop 0 sortedItems) where
sortedItems = List.sort items
loop _ [] = []
loop expected (Located pos num:rest) = result where
rest' = loop (num + 1) rest
result = if num == expected
then rest'
else err:rest' where
err = newErrorMessage (Message message) pos
message = printf "Skipped number %d. %s must be numbered sequentially starting \
\from zero." expected kind
maxFieldNumber = 1023
requireFieldNumbersInRange fieldNums =
Active () [ fieldNumError num pos | Located pos num <- fieldNums, num > maxFieldNumber ] where
fieldNumError num = newErrorMessage (Message
(printf "Field number %d too large; maximum is %d." num maxFieldNumber))
requireNoDuplicateNames :: [Declaration] -> Status()
requireNoDuplicateNames decls = Active () (loop (List.sort locatedNames)) where
locatedNames = mapMaybe declarationName decls
loop (Located pos1 val1:Located pos2 val2:t) =
if val1 == val2
then dupError val1 pos1:dupError val2 pos2:loop2 val1 t
else loop t
loop _ = []
loop2 val1 l@(Located pos2 val2:t) =
if val1 == val2
then dupError val2 pos2:loop2 val1 t
else loop l
loop2 _ _ = []
dupError val = newErrorMessage (Message message) where
message = printf "Duplicate declaration \"%s\"." val
------------------------------------------------------------------------------------------
data CompiledDecl = CompiledMember String (Status Desc)
| CompiledOption (Status OptionAssignmentDesc)
......@@ -242,8 +305,6 @@ compileChildDecls desc decls = Active (members, memberMap, options) errors where
| CompiledOption (Active o _) <- compiledDecls]
errors = concatMap compiledErrors compiledDecls
doAll statuses = Active [x | (Active x _) <- statuses] (concatMap statusErrors statuses)
compileDecl scope (AliasDecl (Located _ name) target) =
CompiledMember name (do
targetDesc <- lookupDesc scope target
......@@ -267,6 +328,8 @@ compileDecl scope (ConstantDecl (Located _ name) t (Located valuePos value)) =
compileDecl scope (EnumDecl (Located _ name) decls) =
CompiledMember name (feedback (\desc -> do
(members, memberMap, options) <- compileChildDecls desc decls
requireNoDuplicateNames decls
requireSequentialNumbering "Enum values" [ num | EnumValueDecl _ num _ <- decls ]
return (DescEnum EnumDesc
{ enumName = name
, enumParent = scope
......@@ -289,6 +352,10 @@ compileDecl scope (EnumValueDecl (Located _ name) (Located _ number) decls) =
compileDecl scope (StructDecl (Located _ name) decls) =
CompiledMember name (feedback (\desc -> do
(members, memberMap, options) <- compileChildDecls desc decls
requireNoDuplicateNames decls
fieldNums <- return [ num | FieldDecl _ num _ _ _ <- decls ]
requireSequentialNumbering "Fields" fieldNums
requireFieldNumbersInRange fieldNums
return (DescStruct StructDesc
{ structName = name
, structParent = scope
......@@ -322,6 +389,8 @@ compileDecl scope (FieldDecl (Located _ name) (Located _ number) typeExp default
compileDecl scope (InterfaceDecl (Located _ name) decls) =
CompiledMember name (feedback (\desc -> do
(members, memberMap, options) <- compileChildDecls desc decls
requireNoDuplicateNames decls
requireSequentialNumbering "Methods" [ num | MethodDecl _ num _ _ _ <- decls ]
return (DescInterface InterfaceDesc
{ interfaceName = name
, interfaceParent = scope
......@@ -372,6 +441,7 @@ compileParam scope (name, typeExp, defaultValue) = do
compileFile name decls =
feedback (\desc -> do
(members, memberMap, options) <- compileChildDecls (DescFile desc) decls
requireNoDuplicateNames decls
return FileDesc
{ fileName = name
, fileImports = []
......
compiler/src/Grammar.hs
View file @ f0877237
......@@ -39,8 +39,9 @@ data FieldValue = VoidFieldValue
| IntegerFieldValue Integer
| FloatFieldValue Double
| StringFieldValue String
| ArrayFieldValue [FieldValue]
| RecordFieldValue [(String, FieldValue)]
| IdentifierFieldValue String
| ListFieldValue [Located FieldValue]
| RecordFieldValue [(Located String, Located FieldValue)]
deriving (Show)
data Declaration = AliasDecl (Located String) DeclName
......@@ -56,3 +57,14 @@ data Declaration = AliasDecl (Located String) DeclName
TypeExpression [Declaration]
| OptionDecl DeclName (Located FieldValue)
deriving (Show)
declarationName :: Declaration -> Maybe (Located String)
declarationName (AliasDecl n _) = Just n
declarationName (ConstantDecl n _ _) = Just n
declarationName (EnumDecl n _) = Just n
declarationName (EnumValueDecl n _ _) = Just n
declarationName (StructDecl n _) = Just n
declarationName (FieldDecl n _ _ _ _) = Just n
declarationName (InterfaceDecl n _) = Just n
declarationName (MethodDecl n _ _ _ _) = Just n
declarationName (OptionDecl _ _) = Nothing
compiler/src/Lexer.hs
View file @ f0877237
......@@ -86,6 +86,7 @@ token = keyword
<|> liftM (const Colon) (symbol ":")
<|> liftM (const Period) (symbol ".")
<|> liftM (const EqualsSign) (symbol "=")
<|> liftM (const MinusSign) (symbol "-")
<?> "token"
locatedToken = located token
......
compiler/src/Main.hs
View file @ f0877237
......@@ -25,6 +25,10 @@ module Main ( main ) where
import System.Environment
import Compiler
import Util(delimit)
import Text.Parsec.Pos
import Text.Parsec.Error
import Text.Printf(printf)
main::IO()
main = do
......@@ -35,5 +39,22 @@ handleFile filename = do
text <- readFile filename
case parseAndCompileFile filename text of
Active desc [] -> print desc
Active _ e -> mapM_ print e
Failed e -> mapM_ print e
Active _ e -> mapM_ printError e
Failed e -> mapM_ printError e
--printError e = mapM_ printMessage (errorMessages e) where
-- pos = errorPos e
-- f = sourceName pos
-- l = sourceLine pos
-- c = sourceColumn pos
-- printMessage :: Message -> IO ()
-- printMessage m = printf "%s:%d:%d: %s\n" f l c (messageString m)
printError e = printf "%s:%d:%d: %s\n" f l c m' where
pos = errorPos e
f = sourceName pos
l = sourceLine pos
c = sourceColumn pos
m = showErrorMessages "or" "Unknown parse error" "Expected" "Unexpected" "end of expression"
(errorMessages e)
m' = delimit "; " (lines m)
compiler/src/Parser.hs
View file @ f0877237
......@@ -25,12 +25,31 @@ module Parser (parseFile) where
import Text.Parsec hiding (tokens)
import Token
import Control.Monad (liftM)
import Grammar
import Lexer (lexer)
import Control.Monad.Identity
tokenParser :: (Located Token -> Maybe a) -> Parsec [Located Token] u a
tokenParser = token (show . locatedValue) locatedPos
tokenParser = token (tokenErrorString . locatedValue) locatedPos
tokenErrorString (Identifier s) = "identifier \"" ++ s ++ "\""
tokenErrorString (ParenthesizedList _) = "parenthesized list"
tokenErrorString (BracketedList _) = "bracketed list"
tokenErrorString (LiteralInt i) = "integer literal " ++ show i
tokenErrorString (LiteralFloat f) = "float literal " ++ show f
tokenErrorString (LiteralString s) = "string literal " ++ show s
tokenErrorString AtSign = "\"@\""
tokenErrorString Colon = "\":\""
tokenErrorString Period = "\".\""
tokenErrorString EqualsSign = "\"=\""
tokenErrorString MinusSign = "\"-\""
tokenErrorString ImportKeyword = "\"import\""
tokenErrorString UsingKeyword = "\"using\""
tokenErrorString ConstKeyword = "\"const\""
tokenErrorString EnumKeyword = "\"enum\""
tokenErrorString StructKeyword = "\"struct\""
tokenErrorString InterfaceKeyword = "\"interface\""
tokenErrorString OptionKeyword = "\"option\""
type TokenParser = Parsec [Located Token] [ParseError]
......@@ -49,22 +68,23 @@ matchLiteralFloat t = case locatedValue t of { (LiteralFloat v) -> Jus
matchLiteralString t = case locatedValue t of { (LiteralString v) -> Just v; _ -> Nothing }
matchSimpleToken expected t = if locatedValue t == expected then Just () else Nothing
identifier = tokenParser matchIdentifier
literalInt = tokenParser matchLiteralInt
literalFloat = tokenParser matchLiteralFloat
literalString = tokenParser matchLiteralString
atSign = tokenParser (matchSimpleToken AtSign)
colon = tokenParser (matchSimpleToken Colon)
period = tokenParser (matchSimpleToken Period)
equalsSign = tokenParser (matchSimpleToken EqualsSign)
importKeyword = tokenParser (matchSimpleToken ImportKeyword)
usingKeyword = tokenParser (matchSimpleToken UsingKeyword)
constKeyword = tokenParser (matchSimpleToken ConstKeyword)
enumKeyword = tokenParser (matchSimpleToken EnumKeyword)
structKeyword = tokenParser (matchSimpleToken StructKeyword)
interfaceKeyword = tokenParser (matchSimpleToken InterfaceKeyword)
optionKeyword = tokenParser (matchSimpleToken OptionKeyword)
identifier = tokenParser matchIdentifier <?> "identifier"
literalInt = tokenParser matchLiteralInt <?> "integer"
literalFloat = tokenParser matchLiteralFloat <?> "floating-point number"
literalString = tokenParser matchLiteralString <?> "string"
atSign = tokenParser (matchSimpleToken AtSign) <?> "\"@\""
colon = tokenParser (matchSimpleToken Colon) <?> "\":\""
period = tokenParser (matchSimpleToken Period) <?> "\".\""
equalsSign = tokenParser (matchSimpleToken EqualsSign) <?> "\"=\""
minusSign = tokenParser (matchSimpleToken MinusSign) <?> "\"=\""
importKeyword = tokenParser (matchSimpleToken ImportKeyword) <?> "\"import\""
usingKeyword = tokenParser (matchSimpleToken UsingKeyword) <?> "\"using\""
constKeyword = tokenParser (matchSimpleToken ConstKeyword) <?> "\"const\""
enumKeyword = tokenParser (matchSimpleToken EnumKeyword) <?> "\"enum\""
structKeyword = tokenParser (matchSimpleToken StructKeyword) <?> "\"struct\""
interfaceKeyword = tokenParser (matchSimpleToken InterfaceKeyword) <?> "\"interface\""
optionKeyword = tokenParser (matchSimpleToken OptionKeyword) <?> "\"option\""
parenthesizedList parser = do
items <- tokenParser matchParenthesizedList
......@@ -155,16 +175,22 @@ fieldDecl statements = do
children <- parseBlock fieldLine statements
return (FieldDecl name ordinal t value children)
negativeFieldValue = liftM (IntegerFieldValue . negate) literalInt
<|> liftM (FloatFieldValue . negate) literalFloat
fieldValue = liftM IntegerFieldValue literalInt
<|> liftM FloatFieldValue literalFloat
<|> liftM StringFieldValue literalString
<|> liftM ArrayFieldValue (bracketedList fieldValue)
<|> liftM IdentifierFieldValue identifier
<|> liftM ListFieldValue (bracketedList (located fieldValue))
<|> liftM RecordFieldValue (parenthesizedList fieldAssignment)
<|> (minusSign >> negativeFieldValue)
<?> "default value"
fieldAssignment = do
name <- identifier
name <- located identifier
equalsSign
value <- fieldValue
value <- located fieldValue
return (name, value)
fieldLine :: Maybe [Located Statement] -> TokenParser Declaration
......@@ -186,6 +212,7 @@ methodDecl statements = do
atSign
ordinal <- located literalInt
params <- parenthesizedList paramDecl
colon
t <- typeExpression
children <- parseBlock methodLine statements
return (MethodDecl name ordinal params t children)
......@@ -227,8 +254,16 @@ parseBlock parser statements = finish where
return [ result | Right (result, _) <- results ]
parseCollectingErrors :: TokenParser a -> [Located Token] -> Either ParseError (a, [ParseError])
parseCollectingErrors parser = runParser parser' [] "" where
parseCollectingErrors parser tokens = runParser parser' [] "" tokens where
parser' = do
-- Work around Parsec bug: Text.Parsec.Print.token is supposed to produce a parser that
-- sets the position by using the provided function to extract it from each token. However,
-- it doesn't bother to call this function for the *first* token, only subsequent tokens.
-- The first token is always assumed to be at 1:1. To fix this, set it manually.
case tokens of
Located pos _:_ -> setPosition pos
[] -> return ()
result <- parser
eof
errors <- getState
......
compiler/src/Semantics.hs
View file @ f0877237
......@@ -30,6 +30,7 @@ import Data.Word (Word8, Word16, Word32, Word64)
import Data.Char (chr)
import Text.Printf(printf)
import Control.Monad(join)
import Util(delimit)
type ByteString = [Word8]
......@@ -81,7 +82,7 @@ data BuiltinType = BuiltinVoid | BuiltinBool
| BuiltinInt8 | BuiltinInt16 | BuiltinInt32 | BuiltinInt64
| BuiltinUInt8 | BuiltinUInt16 | BuiltinUInt32 | BuiltinUInt64
| BuiltinFloat32 | BuiltinFloat64
| BuiltinText | BuiltinBytes
| BuiltinText | BuiltinData
deriving (Show, Enum, Bounded, Eq)
builtinTypes = [minBound::BuiltinType .. maxBound::BuiltinType]
......@@ -103,7 +104,10 @@ data ValueDesc = VoidDesc
| Float32Desc Float
| Float64Desc Double
| TextDesc String
| BytesDesc ByteString
| DataDesc ByteString
| EnumValueValueDesc EnumValueDesc
| StructValueDesc [(FieldDesc, ValueDesc)]
| ListDesc [ValueDesc]
deriving (Show)
valueString VoidDesc = error "Can't stringify void value."
......@@ -119,7 +123,11 @@ valueString (UInt64Desc i) = show i
valueString (Float32Desc x) = show x
valueString (Float64Desc x) = show x
valueString (TextDesc s) = show s
valueString (BytesDesc s) = show (map (chr . fromIntegral) s)
valueString (DataDesc s) = show (map (chr . fromIntegral) s)
valueString (EnumValueValueDesc v) = enumValueName v
valueString (StructValueDesc l) = "(" ++ delimit ", " (map assignmentString l) ++ ")" where
assignmentString (field, value) = fieldName field ++ " = " ++ valueString value
valueString (ListDesc l) = "[" ++ delimit ", " (map valueString l) ++ "]" where
data TypeDesc = BuiltinType BuiltinType
| EnumType EnumDesc
......
compiler/src/Token.hs
View file @ f0877237
......@@ -26,11 +26,17 @@ module Token where
import Text.Parsec.Pos (SourcePos, sourceLine, sourceColumn)
import Text.Printf (printf)
data Located t = Located { locatedPos :: SourcePos, locatedValue :: t } deriving (Eq)
data Located t = Located { locatedPos :: SourcePos, locatedValue :: t }
instance Show t => Show (Located t) where
show (Located pos x) = printf "%d:%d:%s" (sourceLine pos) (sourceColumn pos) (show x)
instance Eq a => Eq (Located a) where
Located _ a == Located _ b = a == b
instance Ord a => Ord (Located a) where
compare (Located _ a) (Located _ b) = compare a b
data Token = Identifier String
| ParenthesizedList [[Located Token]]
| BracketedList [[Located Token]]
......@@ -41,6 +47,7 @@ data Token = Identifier String
| Colon
| Period
| EqualsSign
| MinusSign
| ImportKeyword
| UsingKeyword
| ConstKeyword
......
compiler/src/Util.hs 0 → 100644
View file @ f0877237
-- Copyright (c) 2013, Kenton Varda <temporal@gmail.com>
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
-- 1. Redistributions of source code must retain the above copyright notice, this
-- list of conditions and the following disclaimer.
-- 2. Redistributions in binary form must reproduce the above copyright notice,
-- this list of conditions and the following disclaimer in the documentation
-- and/or other materials provided with the distribution.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
module Util where
delimit delimiter list = concat $ loop list where
loop ("":t) = loop t
loop (a:"":t) = loop (a:t)
loop (a:b:t) = a:delimiter:loop (b:t)
loop a = a
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment