operate-do (empty) → 0.1.0

raw patch · 11 files changed

+516/−0 lines, 11 filesdep +QuickCheckdep +basedep +charsetsetup-changed

Dependencies added: QuickCheck, base, charset, doctest, filemanip, haskell-src-meta, hspec, operate-do, template-haskell

Files

• LICENSE +9/−0
• README.md +113/−0
• Setup.hs +4/−0
• operate-do.cabal +70/−0
• src/Control/Operate.hs +87/−0
• src/Control/Operate/Internal.hs +89/−0
• src/Control/Operate/Types.hs +51/−0
• src/Language/Haskell/TH/Extra.hs +33/−0
• test/Control/OperateSpec.hs +39/−0
• test/Doctests.hs +20/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,9 @@+MIT License (MIT)++Copyright (c) 2016 uecmma++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,113 @@+# Operate Do++This packages provides an useful syntax sugar for infixing.++## Usage++```haskell+-- Same as `pure const <*> Just 1 <*> Just 2 == Just 1`+[opdo| <*> ->+  pure const+  Just 1+  Just 2+  |]+```++## The reason why++When we make complexible program, we use many brackets:++```haskell+dataParser = ComplexData+  <$> (takeWhile1 isToken <* char8 ' ')+  <*> (takeWhile1 (/= 32) <* char8 ' ')+  <*> (some <* endOfLine)+```++`Operate do` provides non-use brackets interface:++```haskell+-- Or `[opdo| <*> -> { pure ComplexData; ... } |]`+[opdo| <*> ->+  pure ComplexData+  takeWhile1 isToken <* char8 ' '+  takeWhile1 (/= 32) <* char8 ' '+  some <* endOfLine+  |]+```++Of course, you can free to use `$`.  Moreover, this is used as weak `do`:++```haskell+-- Same `do { putStrLn "Hello"; putStrLn "World" }`+[opdo| >> ->+  putStrLn "Hello"+  putStrLn "World"+  |]+```++## Syntax++```text+<operate do>     ::= [opdo| <opdooperator> -> { <opdostatements> <expression> [;] }]+<opdooperator>   ::= <identifer>+                   | ( <identifer> )+<opdostatements> ::= <opdostatements> <opdostatement>+                   |+<opdostatement>  ::= <expression> ;+                   | ;+```++An example:++```haskell+[opdo| >>> -> { (+ 1); show; head } |] :: Num a => a -> Char++# Same (use section version)+[opdo| (>>>) -> { (+ 1); show; head } |]+```++Allow multiline statement same as `do` notation:++```haskell+[opdo| >>> ->+  (+ 1)+  show+  head+|]++# Same (brackets multiline)+[opdo| >>> -> {+  (+ 1);+  show;+  head;+}|]+```++This is not supported from some reason:++```haskell+# This is compile error!+[opdo| >>> -> (+ 1)+              show+              head+|]+```++## Translation++### For operation++Taking associativity into consideration:++```haskell+[opdo| op -> a; b; c |] == a op b op c+```++### For function++Take left associativity:++```haskell+[opdo| func -> a; b; c |] == a `func` b `func` c+```

@@ -0,0 +1,4 @@+import           Distribution.Simple++main :: IO ()+main = defaultMain

@@ -0,0 +1,70 @@+name:           operate-do+version:        0.1.0+synopsis:       Simple project template from stack+description:    Please see README.md+category:       Meta+homepage:       https://github.com/uecmma/haskell-library-collections/tree/master/operate-do+bug-reports:    https://github.com/uecmma/haskell-library-collections/issues+author:         uecmma+maintainer:     developer@mma.club.uec.ac.jp+copyright:      2016 uecmma+license:        MIT+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files:+    README.md++source-repository head+  type: git+  location: git+https://gitlab.mma.club.uec.ac.jp/uecmma/haskell-library-collections.git++flag test-doctest+  default: True+  manual:  True++library+  ghc-options: -Wall+  hs-source-dirs:+      src+  exposed-modules:+      Control.Operate+      Control.Operate.Internal+      Control.Operate.Types+  other-modules:+      Language.Haskell.TH.Extra+  build-depends:+      base >= 4.7 && < 5+    , charset+    , haskell-src-meta >= 0.2+    , template-haskell >= 2.11 && < 3+  default-language: Haskell2010++test-suite spec-test+  type: exitcode-stdio-1.0+  ghc-options: -Wall+  main-is: Spec.hs+  hs-source-dirs:+      test+  other-modules:+      Control.OperateSpec+  build-depends:+      base+    , operate-do+    , QuickCheck+    , hspec+  default-language: Haskell2010++test-suite doc-test+  type: exitcode-stdio-1.0+  ghc-options: -Wall -threaded+  main-is: test/Doctests.hs+  default-language: Haskell2010++  if !flag (test-doctest)+    buildable: False+  else+    build-depends:+        base+      , doctest+      , filemanip

@@ -0,0 +1,87 @@+{-# LANGUAGE TemplateHaskell #-}++module Control.Operate+  ( opdo+  ) where++import           Control.Operate.Internal+import           Control.Operate.Types+import           Data.Semigroup+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote++-- | operate do notation+--+-- Syntax:+--+-- @+--   <lexp>     ::= <operator> ar { <opcmds> }        (opdo expression)+--   <ar>       ::= ->+--   <operator> ::= <identity>+--                | ( <identity> )                    (for section)+--   <opcmds>   ::= <opcmd_1> ... <opcmd_n> <exp> [;] (n >= 0)+--   <opcmd>    ::= <exp> ;+--                | ;                                 (empty statement)+-- @+--+-- Sematics:+--+-- @+--   [opdo| _  -> { e } |] = e+-- @+--+-- * InfixL Operator:+--+-- @+--   [opdo| op -> { stmts e } |] = op [opdo| op -> { stmts } |] e+-- @+--+-- * InfixR Operator:+--+-- @+--   [opdo| op -> { e; stmts } |] = op e [opdo| op -> { stmts } |]+-- @+--+-- Examples:+--+-- >>> [opdo| (.) -> { head; show; id } |] 1+-- '1'+--+-- >>> [opdo| . -> { head; show; id } |] 1+-- '1'+--+-- >>> [opdo| <*> -> { pure const; Just 1; Nothing } |]+-- Nothing+--+-- >>> :{+-- [opdo| const -> {+--   "str";+--   1+-- }|]+-- :}+-- "str"+--+-- >>> :{+-- "show: " ++ [opdo| (.) ->+--   \x ->+--     tail x+--   show+-- |] 10+-- :}+-- "show: 0"+--+opdo :: QuasiQuoter+opdo = QuasiQuoter+  { quoteExp  = opdoExpQ+  , quotePat  = nonsense "pattern"+  , quoteType = nonsense "type"+  , quoteDec  = nonsense "declaration"+  }+  where+    nonsense context = fail+      $  "You can't use opdo in "+      <> context+      <> " context, that doesn't even make sense."++opdoExpQ :: String -> ExpQ+opdoExpQ s = runOpdo <$> parseOperateDoExp s

@@ -0,0 +1,89 @@+module Control.Operate.Internal+  ( parseOperateDoExp+  ) where++import           Control.Operate.Types+import           Data.Semigroup+import           Language.Haskell.Meta+import           Language.Haskell.TH+import           Language.Haskell.TH.Extra++parseOperateDoExp :: String -> Q OperateDoExp+parseOperateDoExp s = do+  (opInfo, restS) <- parseOperatorPrefix s+  stmts <- parseOpdoStmts restS+  return $ OperateDoExp+    { opdoOperator   = opInfo+    , opdoStatements = stmts+    }++formatOperatorExp :: String -> Q OpdoOperatorInfo+formatOperatorExp identS = do+  mayName <- lookupValueName identS+  name <- maybe (fail $ "cannot find " <> identS) return mayName+  mayFixity <- reifyFixity name+  let dir = maybe InfixL (\(Fixity _ fixityDir) -> fixityDir) mayFixity+  opDir <- case dir of+    InfixL -> return LeftOperator+    InfixR -> return RightOperator+    InfixN -> fail "InfixN operator is not supported"+  return $ OpdoOperatorInfo opDir $ VarE name++parseOperatorExp :: String -> Q OpdoOperatorInfo+parseOperatorExp ['(']    = fail "Parse error: ("+parseOperatorExp ('(':xs) = do+  let xsLeng = length xs+  let (ts, t) = splitAt (xsLeng - 1) xs+  if t == ")"+    then formatOperatorExp ts+    else fail "Cannot find ')'"+parseOperatorExp identS   = formatOperatorExp identS++parseOperatorPrefix :: String -> Q (OpdoOperatorInfo, String)+parseOperatorPrefix s = do+  let noPrefS = dropWhile isHsWhitespace s+  let (identS, postS) = break isHsWhitespace noPrefS+  opInfo <- parseOperatorExp identS+  restS <- rmArrowPrefix postS+  return (opInfo, restS)++rmArrowPrefix :: String -> Q String+rmArrowPrefix ('-':'>':xs) = return xs+rmArrowPrefix ('→':xs)     = do+  b <- isExtEnabled UnicodeSyntax+  if b+    then return xs+    else fail "Unicode arrow character is only supported with `UnicodeSyntax` Pragma"+rmArrowPrefix (x:xs)+  | isHsWhitespace x       = rmArrowPrefix xs+rmArrowPrefix []           = fail "Parse error: no statements"+rmArrowPrefix (x:_)        = fail $ "Parse error: " <> [x]++formatDoStmts :: Stmt -> Q OpdoStmt+formatDoStmts (NoBindS expr) = return $ OpdoExpS expr+formatDoStmts (LetS _)       = fail "LetS is not supported"+formatDoStmts (BindS _ _)    = fail "BindS is not supported"+formatDoStmts (ParS _)       = fail "ParS is not supported"++formatOpdoStmts :: [OpdoStmt] -> Q OpdoStatements+formatOpdoStmts [OpdoExpS expr] = return $ OpdoStatements [] expr+formatOpdoStmts (x:xs)          = do+  OpdoStatements es e <- formatOpdoStmts xs+  return $ OpdoStatements (x:es) e+formatOpdoStmts _               = fail "least an expression"++-- TODO: support this syntax (indent base parse)+--+-- @+--   [opdo| const -> 1+--                   "str"+--   |]+-- @+parseOpdoStmts :: String -> Q OpdoStatements+parseOpdoStmts stmtsStr = do+  let prefix = "do "+  stmts <- case parseExp $ prefix <> stmtsStr of+    Right (DoE stmts) -> mapM formatDoStmts stmts+    Right _           -> fail "illegal statement"+    Left msg          -> fail msg+  formatOpdoStmts stmts

@@ -0,0 +1,51 @@+module Control.Operate.Types+  ( OperateDoExp (..)+  , OpdoStmt (..)+  , OperatorDirection (..)+  , OpdoOperatorInfo (..)+  , OpdoStatements (..)+  , runOpdo+  ) where++import           Language.Haskell.TH++data OpdoOperatorInfo = OpdoOperatorInfo+  { getOperatorDirection  :: OperatorDirection+  , getOperatorExpression :: Exp+  } deriving (Eq, Ord, Show)++data OpdoStatements = OpdoStatements+  { getOpCmds       :: [OpdoStmt]+  , getOpCmdLastOne :: Exp+  } deriving (Eq, Ord, Show)++data OperateDoExp = OperateDoExp+  { opdoOperator   :: OpdoOperatorInfo+  , opdoStatements :: OpdoStatements+  } deriving (Eq, Ord, Show)++data OpdoStmt+  = OpdoExpS Exp+  deriving (Show, Ord, Eq)++data OperatorDirection+  = LeftOperator+  | RightOperator+  deriving (Eq, Ord, Show, Enum)++runOpdo :: OperateDoExp -> Exp+runOpdo (OperateDoExp+  (OpdoOperatorInfo LeftOperator opExp)+  (OpdoStatements stmts expr)) = go stmts+  where+    go []               = expr+    go ~(OpdoExpS x:xs) = AppE (AppE opExp $ go' xs x) expr++    go' []               cont = cont+    go' ~(OpdoExpS x:xs) cont = go' xs $ AppE (AppE opExp cont) x+runOpdo (OperateDoExp+  (OpdoOperatorInfo RightOperator opExp)+  (OpdoStatements stmts expr)) = go stmts+  where+    go []               = expr+    go ~(OpdoExpS x:xs) = AppE (AppE opExp x) $ go xs

@@ -0,0 +1,33 @@+module Language.Haskell.TH.Extra+  ( isHsWhitespace+  ) where++import qualified Data.CharSet                  as UCS+import qualified Data.CharSet.Unicode.Category as UCS++-- | Is Haskell whitespace character+--+-- Examples:+--+-- >>> isHsWhitespace ' '+-- True+--+-- >>> isHsWhitespace '\r'+-- True+--+-- >>> isHsWhitespace '　'+-- True+--+-- >>> isHsWhitespace 'w'+-- False+--+isHsWhitespace :: Char -> Bool+isHsWhitespace c = UCS.member c $+  foldl1 UCS.union+  [ UCS.space+  , UCS.singleton '\t'+  , UCS.singleton '\v'+  , UCS.singleton '\r'+  , UCS.singleton '\n'+  , UCS.singleton '\f'+  ]

@@ -0,0 +1,39 @@+{-# LANGUAGE QuasiQuotes #-}++module Control.OperateSpec where++import           Control.Operate+import           Test.Hspec+import           Test.QuickCheck++spec :: Spec+spec = do++  describe "opdo" $ do++    it "just return an expression" $ property $+      \x ->+        [opdo| const -> x |] == (x :: Int)+        && [opdo| + -> x |] == x++    it "return infix value for left assoc" $ property $+      \x ->+        (==) [opdo| - -> x; 1; 2 |] $ (x :: Int) - 1 - 2++    it "return infix value for right assoc" $ property $+      \x ->+        (==) [opdo| ** -> x; 1; 2 |] $ (x :: Double) ** 1 ** 2++    it "return infix value for function" $ property $+      \x ->+        (==) [opdo| const -> x; "str"; 'c' |] $ (x :: Int) `const` "str" `const` 'c'++    it "should be through type check" $ do+      [opdo| <*> -> pure const; return True; fail "error" |] `shouldBe` Nothing++    it "should allow multiline" $ do+      [opdo| <*> ->+        pure const+        return True+        fail "error"+        |] `shouldBe` Nothing

@@ -0,0 +1,20 @@+module Main where++import           Data.Semigroup+import           System.FilePath.Find+import           Test.DocTest++main :: IO ()+main = do+  files <- find always (extension ==? ".hs") "src"+  tfiles <- find always (extension ==? ".hs") "test"+  doctest $+    [ "-isrc"+    , "-XOverloadedStrings"+    , "-XFlexibleInstances"+    , "-XMultiParamTypeClasses"+    , "-XTemplateHaskell"+    , "-XQuasiQuotes"+    ]+    <> files+    <> filter (`notElem` ["test/Doctests.hs"]) tfiles

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}