rl-satton 0.1.2.2 → 0.1.2.3
raw patch · 7 files changed
+600/−473 lines, 7 files
Files
- rl-satton.cabal +5/−2
- src/Control/Break_RL.hs +114/−0
- src/Control/Monad/Rnd.hs +0/−7
- src/Graphics/TinyPlot.hs +1/−1
- src/RL/Heredoc.hs +0/−459
- src/RL/Imports.hs +19/−4
- src/Text/Heredoc_RL.hs +461/−0
rl-satton.cabal view
@@ -1,5 +1,5 @@ name: rl-satton-version: 0.1.2.2+version: 0.1.2.3 author: Sergey Mironov maintainer: grrwlf@gmail.com category: Machine Learning@@ -31,7 +31,10 @@ RL.Utils Graphics.TinyPlot Control.Monad.Rnd- RL.Heredoc++ other-modules:+ Control.Break_RL+ Text.Heredoc_RL default-extensions: LambdaCase,
+ src/Control/Break_RL.hs view
@@ -0,0 +1,114 @@+{- This module was copyed from `break` package. Reason: original version doesn't+ - export `unBreak`, thus forbids writing new combinators (such as `iter`) on+ - its base. -}++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-| Example usage:++> import Control.Break+> import Control.Monad.State+> import Prelude hiding (break)+>+> example :: State Int ()+> example = loop (do+> n <- lift get -- Inside a `loop`, wrap commands in `lift`+> if n < 10+> then lift (put (n + 1)) -- You keep looping by default+> else break () ) -- Use `break` to exit from the `loop`++The `loop` command runs the given command repeatedly until the command breaks+from the `loop` using `break`:++>>> execState example 0+10++For some effects (like `Control.Monad.Trans.State`), you can omit `lift`:++> example :: State Int ()+> example = loop (do+> n <- get+> if n < 10+> then put (n + 1)+> else break () )++ The `loop` will return whatever value you supply to `break`:++> example :: State Int Bool+> example = loop (do+> n <- get+> if n < 10+> then put (n + 1)+> else break True )++>>> runState example 0+(True,10)++-}++module Control.Break_RL (+ -- * Break+ Break(..)+ , loop+ , break++ -- * Re-exports+ , lift+ ) where++import Control.Applicative (Applicative)+import Control.Monad (forever)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)+import Control.Monad.Cont (MonadCont )+import Control.Monad.State (MonadState )+import Control.Monad.Writer (MonadWriter)+import Prelude hiding (break)++{-| For the most common use cases you will:++ * build `Break` commands using `lift` or `break`++ * combine `Break` commands using @do@ notation++ * consume `Break` commands using `loop`++ The meaning of the type parameters:++ * @r@: the argument type of `break` and the return type of the `loop`++ * @m@: the base `Monad` that you are running in a `loop`++ * @a@: the return type of a `Break` command (not the same as the return+ value of the `loop`)+-}+newtype Break r m a = Break { unBreak :: ExceptT r m a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadTrans+ , MonadIO+ , MonadCont+ , MonadState s+ , MonadWriter w+ )++{-| `break` from a `loop`++ The argument you supply to `break` is the return value of the `loop`+-}+break :: Monad m => r -> Break r m a+break r = Break (throwE r)++{-| @(loop m)@ runs the action @\'m\'@ repeatedly until you `break` from the+ `loop`+-}+loop :: Monad m => Break r m () -> m r+loop m = do+ x <- runExceptT (unBreak (forever m))+ case x of+ Left r -> return r+ Right r -> return r+
src/Control/Monad/Rnd.hs view
@@ -8,9 +8,7 @@ import Control.Monad.Identity import Control.Monad.State.Strict-import Control.Break import System.Random--- import Imports class (Monad m, RandomGen g) => MonadRnd g m | m -> g where roll :: (g -> (a,g)) -> m a@@ -51,11 +49,6 @@ return a instance (MonadRnd g m) => MonadRnd g (StateT s m) where- getGen = lift getGen- putGen = lift . putGen- roll = lift . roll--instance (MonadRnd g m) => MonadRnd g (Break r m) where getGen = lift getGen putGen = lift . putGen roll = lift . roll
src/Graphics/TinyPlot.hs view
@@ -13,7 +13,7 @@ import System.IO import System.Process import System.FilePath-import RL.Heredoc+import Text.Heredoc_RL import Text.Printf data PlotData = PlotData {
− src/RL/Heredoc.hs
@@ -1,459 +0,0 @@-{- | Code was incorporated from `heredocs` pacakge, since the original package- - is broken at the moment.- -}--{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module RL.Heredoc ( heredoc- , heredocFile- ) where--import Control.Applicative ((<$>), (<*>))-import Control.Arrow ((***))-import Data.Function (on)-import Data.Monoid ((<>))-import Text.ParserCombinators.Parsec hiding (Line)-import Text.ParserCombinators.Parsec.Error-import Language.Haskell.TH-import Language.Haskell.TH.Quote--heredoc :: QuasiQuoter-heredoc = QuasiQuoter { quoteExp = heredocFromString }--heredocFile :: FilePath -> Q Exp-heredocFile fp = do- content <- runIO $ readFile fp- heredocFromString content---- | C# code gen-heredocFromString :: String -> Q Exp-heredocFromString- = either err (concatToQExp . arrange) . parse doc "heredoc"- where- err = infixE <$> Just . pos <*> pure (varE '(<>)) <*> Just . msg- pos = litE <$> (stringL <$> show . errorPos)- msg = litE <$> (stringL <$> concatMap messageString . errorMessages)--type Indent = Int-type Line' = (Indent, Line)-type ChildBlock = [Line']-type AltFlag = Bool--data InLine = Raw String- | Quoted [Expr]- deriving Show--data Line = CtrlForall [Expr] [Expr] ChildBlock- | CtrlMaybe AltFlag [Expr] [Expr] ChildBlock ChildBlock- | CtrlNothing- | CtrlIf AltFlag [Expr] ChildBlock ChildBlock- | CtrlElse- | CtrlCase [Expr] [([Expr], ChildBlock)]- | CtrlOf [Expr]- | CtrlLet [Expr] [Expr] ChildBlock- | Normal [InLine]- deriving Show--data Expr = S String- | I Integer- | W- | A String Expr- | V String- | V' String- | C String- | O String- | O' String- | E [Expr]- | T [[Expr]]- | L [[Expr]]- | N- deriving Show--eol :: Parser String-eol = try (string "\n\r")- <|> try (string "\r\n")- <|> string "\n"- <|> string "\r"- <?> fail "end of line"--spaceTabs :: Parser String-spaceTabs = many (oneOf " \t")--doc :: Parser [(Indent, Line)]-doc = line `sepBy` eol--line :: Parser (Indent, Line)-line = (,) <$> indent <*> contents--indent :: Parser Indent-indent = fmap sum $- many ((char ' ' >> pure 1) <|>- (char '\t' >> fail "Tabs are not allowed in indentation"))--contents :: Parser Line-contents = try ctrlForall <|>- try ctrlMaybe <|>- try ctrlNothing <|>- try ctrlIf <|>- try ctrlElse <|>- try ctrlCase <|>- try ctrlOf <|>- try ctrlLet <|>- normal--ctrlForall :: Parser Line-ctrlForall = CtrlForall <$> bindVal <*> expr <*> pure []- where- bindVal = string "$forall" *> spaceTabs *>- binding- <* spaceTabs <* string "<-" <* spaceTabs--ctrlMaybe :: Parser Line-ctrlMaybe = CtrlMaybe <$> pure False <*> bindVal <*> expr <*> pure [] <*> pure []- where- bindVal = string "$maybe" *> spaceTabs *>- binding- <* spaceTabs <* string "<-" <* spaceTabs--ctrlNothing :: Parser Line-ctrlNothing = string "$nothing" *> spaceTabs >> pure CtrlNothing--ctrlIf :: Parser Line-ctrlIf = CtrlIf <$> pure False <*> (string "$if" *> spaceTabs *> expr <* spaceTabs) <*> pure [] <*> pure []--ctrlElse :: Parser Line-ctrlElse = string "$else" *> spaceTabs >> pure CtrlElse--ctrlCase :: Parser Line-ctrlCase = CtrlCase <$> (string "$case" *> spaceTabs *> expr <* spaceTabs) <*> pure []--ctrlOf :: Parser Line-ctrlOf = CtrlOf <$> bindVal- where- bindVal = string "$of" *> spaceTabs *>- binding- <* spaceTabs--ctrlLet :: Parser Line-ctrlLet = CtrlLet <$> bindVal <*> expr <*> pure []- where- bindVal = string "$let" *> spaceTabs *>- binding- <* spaceTabs <* string "=" <* spaceTabs--binding :: Parser [Expr]-binding = spaceTabs *> many1 (try (A <$> var <* char '@' <*> term) <|>- term)- where- term :: Parser Expr- term = (C <$> con <|>- T <$> tuple <|>- (try (nil >> pure N) <|>- try (L <$> list) <|>- try (O <$> string ":")) <|> -- only pattern operator- (try (V <$> ((<>) <$> wild <*> many1 (alphaNum <|> oneOf "_'"))) <|>- try (wild >> pure W) <|>- V <$> var)) <* spaceTabs--expr :: Parser [Expr]-expr = spaceTabs *> many1 (try (A <$> var <* char '@' <*> term) <|>- term)- where- term :: Parser Expr- term = (S <$> str <|>- T <$> tuple <|>- (try (nil >> pure N) <|>- try (L <$> list) <|>- try (O <$> op)) <|>- (try (O' <$> op') <|> try (E <$> subexp)) <|>- C <$> con <|>- I <$> integer <|>- V' <$> var' <|>- (try (V <$> ((<>) <$> wild <*> many1 (alphaNum <|> oneOf "_'"))) <|>- try (wild >> pure W) <|>- V <$> var)) <* spaceTabs---tuple :: Parser [[Expr]]-tuple = char '(' *> sepBy expr (char ',') <* char ')'--list :: Parser [[Expr]]-list = char '[' *> sepBy expr (char ',') <* char ']'--integer :: Parser Integer-integer = read <$> many1 digit--str :: Parser String-str = char '"' *> many quotedChar <* char '"'- where- quotedChar :: Parser Char- quotedChar = noneOf "\\\"" <|> try (string "\\\"" >> pure '"')--subexp :: Parser [Expr]-subexp = char '(' *> expr <* char ')'--var :: Parser String-var = (:) <$> lower <*> many (alphaNum <|> oneOf "_'")--var' :: Parser String-var' = char '`' *> var <* char '`'--wild :: Parser String-wild = string "_"--nil :: Parser String-nil = string "[]"--con :: Parser String-con = (:) <$> upper <*> many (alphaNum <|> oneOf "_'")--op :: Parser String-op = many1 (oneOf ":!#$%&*+./<=>?@\\^|-~")--op' :: Parser String-op' = char '(' *> op <* char ')'--normal :: Parser Line-normal = Normal <$> many (try quoted <|> try raw' <|> try raw)--quoted :: Parser InLine-quoted = Quoted <$> (string "${" *> expr <* string "}")--raw' :: Parser InLine-raw' = Raw <$> ((:) <$> (char '$')- <*> ((:) <$> noneOf "{" <*> many (noneOf "$\n\r")))--raw :: Parser InLine-raw = Raw <$> many1 (noneOf "$\n\r")-------arrange :: [(Indent, Line)] -> [(Indent, Line)]-arrange = norm . rev . foldl (flip push) []- where- isCtrlNothing (_, CtrlNothing) = True- isCtrlNothing _ = False- isCtrlElse (_, CtrlElse) = True- isCtrlElse _ = False- isCtrlOf (_, CtrlOf _) = True- isCtrlOf _ = False-- push :: Line' -> [Line'] -> [Line']- push x [] = x:[]- push x ss'@((_, Normal _):_) = x:ss'-- push x@(i, _) ss'@((j, CtrlForall b e body):ss)- | i > j = (j, CtrlForall b e (push x body)):ss- | otherwise = x:ss'-- push x@(i, _) ss'@((j, CtrlLet b e body):ss)- | i > j = (j, CtrlLet b e (push x body)):ss- | otherwise = x:ss'-- push x@(i, _) ss'@((j, CtrlMaybe flg b e body alt):ss)- | i > j = if flg- then (j, CtrlMaybe flg b e body (push x alt)):ss- else (j, CtrlMaybe flg b e (push x body) alt):ss- | i == j && isCtrlNothing x- = if flg- then error "too many $nothing found"- else (j, CtrlMaybe True b e body alt):ss- | otherwise = x:ss'- push x ((j, CtrlNothing):_) = error "orphan $nothing found"-- push x@(i, _) ss'@((j, CtrlIf flg e body alt):ss)- | i > j = if flg- then (j, CtrlIf flg e body (push x alt)):ss- else (j, CtrlIf flg e (push x body) alt):ss- | i == j && isCtrlElse x- = if flg- then error "too many $else found"- else (j, CtrlIf True e body alt):ss- | otherwise = x:ss'- push x ((j, CtrlElse):_) = error "orphan $else found"-- push x@(i, _) ss'@((j, CtrlCase e alts):ss)- | i > j = (j, CtrlCase e (push' x alts)):ss- | otherwise- = if isCtrlOf x- then error "orphan $of found"- else x:ss'- push x ((j, CtrlOf _):_) = error "orphan $of found"-- push' x@(i, CtrlOf e) alts = (e, []):alts- push' x [] = error "$of not found"- push' x ((e, body):alts) = (e, (push x body)):alts-- rev :: [Line'] -> [Line']- rev = foldr (\x xs -> xs ++ [rev' x]) []- rev' :: Line' -> Line'- rev' x@(_, Normal _) = x- rev' (i, CtrlForall b e body)- = (i, CtrlForall b e (rev body))- rev' (i, CtrlLet b e body)- = (i, CtrlLet b e (rev body))- rev' (i, CtrlMaybe flg b e body alt)- = (i, CtrlMaybe flg b e (rev body) (rev alt))- rev' (i, CtrlIf flg e body alt)- = (i, CtrlIf flg e (rev body) (rev alt))- rev' (i, CtrlCase e alts)- = (i, CtrlCase e (map (id *** rev) $ reverse alts))-- norm :: [Line'] -> [Line']- norm = foldr (\x xs -> norm' x:xs) []- norm' :: Line' -> Line'- norm' x@(_, Normal _) = x- norm' (i, CtrlForall b e body)- = (i, CtrlForall b e (normsub i body ++ blockEnd))- norm' (i, CtrlLet b e body)- = (i, CtrlLet b e (normsub i body ++ blockEnd))- norm' (i, CtrlMaybe flg b e body alt)- = (i, CtrlMaybe flg b e (normsub i body ++ blockEnd) (normsub i alt ++ blockEnd))- norm' (i, CtrlNothing) = error "orphan $nothing found"- norm' (i, CtrlIf flg e body alt)- = (i, CtrlIf flg e (normsub i body ++ blockEnd) (normsub i alt ++ blockEnd))- norm' (i, CtrlElse) = error "orphan $else found"- norm' (i, CtrlCase e alts)- = (i, CtrlCase e (map (id *** (++ blockEnd) . normsub i) alts))- norm' (i, CtrlOf _) = error "orphan $of found"-- normsub :: Indent -> [Line'] -> [Line']- normsub i body = let j = minimum $ map fst body- deIndent n = i+(n-j)- in norm $ map (deIndent *** id) body-- blockEnd :: [Line']- blockEnd = [(0, Normal [])]--class ToQPat a where- toQPat :: a -> Q Pat- concatToQPat :: [a] -> Q Pat--instance ToQPat Expr where- toQPat (S s) = litP (stringL s)- toQPat (I i) = litP (integerL i)- toQPat W = wildP- toQPat (V v) = varP (mkName v)- toQPat (O o) = varP (mkName o)- toQPat (E e) = concatToQPat e- toQPat (C c) = conP (mkName c) []- toQPat (T t) = tupP $ map concatToQPat t- toQPat (A a e) = asP (mkName a) $ toQPat e-- -- special case for list- concatToQPat (x:O ":":xs) = infixP (toQPat x)- (mkName ":")- (concatToQPat xs)- concatToQPat ((C c):args) = conP (mkName c) $ map toQPat args- concatToQPat ((V v):args) = varP (mkName v) -- OK?- concatToQPat (p@(T t):[]) = toQPat p -- OK?- concatToQPat (W:[]) = wildP -- OK?- concatToQPat (p@(A _ _):[]) = toQPat p- concatToQPat _ = error "don't support this pattern"--class ToQExp a where- toQExp :: a -> Q Exp- concatToQExp :: [a] -> Q Exp--instance ToQExp Expr where- toQExp (S s) = litE (stringL s)- toQExp (I i) = litE (integerL i)- toQExp W = error "wildcard is NOT legal expression"- toQExp (V v) = varE (mkName v)- toQExp (O o) = varE (mkName o)- toQExp (E e) = concatToQExp e- toQExp (C c) = conE (mkName c)- toQExp (T t) = tupE $ map concatToQExp t- toQExp N = listE []- toQExp (L l) = listE $ map concatToQExp l-- concatToQExp xs = concatToQ' Nothing xs- where- concatToQ' (Just acc) [] = acc- concatToQ' Nothing [x] = toQExp x- concatToQ' Nothing (x:xs) = concatToQ' (Just (toQExp x)) xs- -- spacial case for list- concatToQ' (Just acc) ((O ":"):xs)- = infixE (Just acc)- (conE (mkName ":"))- (Just (concatToQExp xs))- concatToQ' (Just acc) ((O o):xs)- = infixE (Just acc)- (varE (mkName o))- (Just (concatToQExp xs))- concatToQ' (Just acc) ((V' v'):xs)- = infixE (Just acc)- (varE (mkName v'))- (Just (concatToQExp xs))- concatToQ' (Just acc) (x:xs)- = concatToQ' (Just (appE acc (toQExp x))) xs--instance ToQExp InLine where- toQExp (Raw s) = litE (stringL s)- toQExp (Quoted expr) = concatToQExp expr-- concatToQExp [] = litE (stringL "")- concatToQExp (x:xs) = infixE (Just (toQExp x))- (varE '(<>))- (Just (concatToQExp xs))--instance ToQExp Line where- toQExp (CtrlForall b e body)- = appE (appE (appE (varE 'foldr)- (lamE [concatToQPat b]- (infixE (Just (concatToQExp body))- (varE '(<>))- Nothing)))- (litE (stringL "")))- (concatToQExp e)- toQExp (CtrlMaybe flg b e body alt)- = caseE (concatToQExp e)- [ match (conP 'Just [concatToQPat b])- (normalB (concatToQExp body))- []- , match (conP 'Nothing [])- (normalB (concatToQExp alt))- []- ]- toQExp (CtrlIf flg e body alt)- = condE (concatToQExp e) (concatToQExp body) (concatToQExp alt)- toQExp CtrlElse = error "illegal $else found"- toQExp (CtrlCase e alts)- = caseE (concatToQExp e) (map mkMatch alts)- where- mkMatch (e', body) = match (concatToQPat e')- (normalB (concatToQExp body))- []- toQExp (CtrlOf e) = error "illegal $of found"- toQExp (CtrlLet b e body)- = letE [valD (concatToQPat b) (normalB $ concatToQExp e) []]- (concatToQExp body)- toQExp (Normal xs) = concatToQExp xs-- concatToQExp (x:[]) = toQExp x- concatToQExp (x:xs) = infixE (Just (toQExp x))- (varE '(<>))- (Just (concatToQExp xs))--instance ToQExp Line' where- toQExp (n, x@(Normal _))- = infixE (Just (litE (stringL (replicate n ' '))))- (varE '(<>))- (Just (toQExp x))- toQExp (n, x) = toQExp x -- Ctrl*-- concatToQExp [] = litE (stringL "")- concatToQExp (x@(_, Normal _):y:ys)- = infixE (Just (infixE (Just (toQExp x))- (varE '(<>))- (Just (litE (stringL "\n")))))- (varE '(<>))- (Just (concatToQExp (y:ys)))- concatToQExp (x@(_, Normal _):xs)- = infixE (Just (toQExp x))- (varE '(<>))- (Just (concatToQExp xs))- concatToQExp (x:xs) = infixE (Just (toQExp x))- (varE '(<>))- (Just (concatToQExp xs))-
src/RL/Imports.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances #-} module RL.Imports ( module Control.Arrow@@ -8,9 +9,9 @@ , module Control.Monad.Trans , module Control.Monad.State.Strict , module Control.Monad.Rnd- , module Control.Break , module Control.Lens , module Control.Monad.Loops+ , module Control.Break_RL , module Data.Bits , module Data.Ratio , module Data.Tuple@@ -31,7 +32,7 @@ , module System.Random.Mersenne.Pure64 , module System.Directory , module Text.Printf- , module RL.Heredoc+ , module Text.Heredoc_RL , module Text.Show.Pretty , module Graphics.TinyPlot , module RL.Imports@@ -48,9 +49,10 @@ import Control.Monad.Trans import Control.Monad.State.Strict import Control.Monad.Rnd-import Control.Break import Control.Lens (Lens', makeLenses, (%=), (^.), view, use, uses, zoom, _1, _2, _3, _4, _5, _6) import Control.Monad.Loops+import Control.Break_RL+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Bits import Data.Ratio import Data.Tuple@@ -72,7 +74,7 @@ import System.Random.Mersenne.Pure64 import System.Directory import Text.Printf-import RL.Heredoc+import Text.Heredoc_RL import Text.Show.Pretty import Graphics.TinyPlot import Data.Text (Text)@@ -91,4 +93,17 @@ trace' a b = trace (ppShow a) b loopM s0 f m = iterateUntilM (not . f) m s0+++iter :: Monad m => r -> (r -> Break r m r) -> m r+iter r0 f = do+ x <- runExceptT (unBreak (f r0))+ case x of+ Left r -> return r+ Right r -> iter r f++instance (MonadRnd g m) => MonadRnd g (Break r m) where+ getGen = lift getGen+ putGen = lift . putGen+ roll = lift . roll
+ src/Text/Heredoc_RL.hs view
@@ -0,0 +1,461 @@+{- | Code was copyed from `heredocs` pacakge, since the original package+ - is broken at the moment.+ -+ - See https://github.com/cutsea110/heredoc/issues/2+ -}++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+module Text.Heredoc_RL ( heredoc+ , heredocFile+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Arrow ((***))+import Data.Function (on)+import Data.Monoid ((<>))+import Text.ParserCombinators.Parsec hiding (Line)+import Text.ParserCombinators.Parsec.Error+import Language.Haskell.TH+import Language.Haskell.TH.Quote++heredoc :: QuasiQuoter+heredoc = QuasiQuoter { quoteExp = heredocFromString }++heredocFile :: FilePath -> Q Exp+heredocFile fp = do+ content <- runIO $ readFile fp+ heredocFromString content++-- | C# code gen+heredocFromString :: String -> Q Exp+heredocFromString+ = either err (concatToQExp . arrange) . parse doc "heredoc"+ where+ err = infixE <$> Just . pos <*> pure (varE '(<>)) <*> Just . msg+ pos = litE <$> (stringL <$> show . errorPos)+ msg = litE <$> (stringL <$> concatMap messageString . errorMessages)++type Indent = Int+type Line' = (Indent, Line)+type ChildBlock = [Line']+type AltFlag = Bool++data InLine = Raw String+ | Quoted [Expr]+ deriving Show++data Line = CtrlForall [Expr] [Expr] ChildBlock+ | CtrlMaybe AltFlag [Expr] [Expr] ChildBlock ChildBlock+ | CtrlNothing+ | CtrlIf AltFlag [Expr] ChildBlock ChildBlock+ | CtrlElse+ | CtrlCase [Expr] [([Expr], ChildBlock)]+ | CtrlOf [Expr]+ | CtrlLet [Expr] [Expr] ChildBlock+ | Normal [InLine]+ deriving Show++data Expr = S String+ | I Integer+ | W+ | A String Expr+ | V String+ | V' String+ | C String+ | O String+ | O' String+ | E [Expr]+ | T [[Expr]]+ | L [[Expr]]+ | N+ deriving Show++eol :: Parser String+eol = try (string "\n\r")+ <|> try (string "\r\n")+ <|> string "\n"+ <|> string "\r"+ <?> fail "end of line"++spaceTabs :: Parser String+spaceTabs = many (oneOf " \t")++doc :: Parser [(Indent, Line)]+doc = line `sepBy` eol++line :: Parser (Indent, Line)+line = (,) <$> indent <*> contents++indent :: Parser Indent+indent = fmap sum $+ many ((char ' ' >> pure 1) <|>+ (char '\t' >> fail "Tabs are not allowed in indentation"))++contents :: Parser Line+contents = try ctrlForall <|>+ try ctrlMaybe <|>+ try ctrlNothing <|>+ try ctrlIf <|>+ try ctrlElse <|>+ try ctrlCase <|>+ try ctrlOf <|>+ try ctrlLet <|>+ normal++ctrlForall :: Parser Line+ctrlForall = CtrlForall <$> bindVal <*> expr <*> pure []+ where+ bindVal = string "$forall" *> spaceTabs *>+ binding+ <* spaceTabs <* string "<-" <* spaceTabs++ctrlMaybe :: Parser Line+ctrlMaybe = CtrlMaybe <$> pure False <*> bindVal <*> expr <*> pure [] <*> pure []+ where+ bindVal = string "$maybe" *> spaceTabs *>+ binding+ <* spaceTabs <* string "<-" <* spaceTabs++ctrlNothing :: Parser Line+ctrlNothing = string "$nothing" *> spaceTabs >> pure CtrlNothing++ctrlIf :: Parser Line+ctrlIf = CtrlIf <$> pure False <*> (string "$if" *> spaceTabs *> expr <* spaceTabs) <*> pure [] <*> pure []++ctrlElse :: Parser Line+ctrlElse = string "$else" *> spaceTabs >> pure CtrlElse++ctrlCase :: Parser Line+ctrlCase = CtrlCase <$> (string "$case" *> spaceTabs *> expr <* spaceTabs) <*> pure []++ctrlOf :: Parser Line+ctrlOf = CtrlOf <$> bindVal+ where+ bindVal = string "$of" *> spaceTabs *>+ binding+ <* spaceTabs++ctrlLet :: Parser Line+ctrlLet = CtrlLet <$> bindVal <*> expr <*> pure []+ where+ bindVal = string "$let" *> spaceTabs *>+ binding+ <* spaceTabs <* string "=" <* spaceTabs++binding :: Parser [Expr]+binding = spaceTabs *> many1 (try (A <$> var <* char '@' <*> term) <|>+ term)+ where+ term :: Parser Expr+ term = (C <$> con <|>+ T <$> tuple <|>+ (try (nil >> pure N) <|>+ try (L <$> list) <|>+ try (O <$> string ":")) <|> -- only pattern operator+ (try (V <$> ((<>) <$> wild <*> many1 (alphaNum <|> oneOf "_'"))) <|>+ try (wild >> pure W) <|>+ V <$> var)) <* spaceTabs++expr :: Parser [Expr]+expr = spaceTabs *> many1 (try (A <$> var <* char '@' <*> term) <|>+ term)+ where+ term :: Parser Expr+ term = (S <$> str <|>+ T <$> tuple <|>+ (try (nil >> pure N) <|>+ try (L <$> list) <|>+ try (O <$> op)) <|>+ (try (O' <$> op') <|> try (E <$> subexp)) <|>+ C <$> con <|>+ I <$> integer <|>+ V' <$> var' <|>+ (try (V <$> ((<>) <$> wild <*> many1 (alphaNum <|> oneOf "_'"))) <|>+ try (wild >> pure W) <|>+ V <$> var)) <* spaceTabs+++tuple :: Parser [[Expr]]+tuple = char '(' *> sepBy expr (char ',') <* char ')'++list :: Parser [[Expr]]+list = char '[' *> sepBy expr (char ',') <* char ']'++integer :: Parser Integer+integer = read <$> many1 digit++str :: Parser String+str = char '"' *> many quotedChar <* char '"'+ where+ quotedChar :: Parser Char+ quotedChar = noneOf "\\\"" <|> try (string "\\\"" >> pure '"')++subexp :: Parser [Expr]+subexp = char '(' *> expr <* char ')'++var :: Parser String+var = (:) <$> lower <*> many (alphaNum <|> oneOf "_'")++var' :: Parser String+var' = char '`' *> var <* char '`'++wild :: Parser String+wild = string "_"++nil :: Parser String+nil = string "[]"++con :: Parser String+con = (:) <$> upper <*> many (alphaNum <|> oneOf "_'")++op :: Parser String+op = many1 (oneOf ":!#$%&*+./<=>?@\\^|-~")++op' :: Parser String+op' = char '(' *> op <* char ')'++normal :: Parser Line+normal = Normal <$> many (try quoted <|> try raw' <|> try raw)++quoted :: Parser InLine+quoted = Quoted <$> (string "${" *> expr <* string "}")++raw' :: Parser InLine+raw' = Raw <$> ((:) <$> (char '$')+ <*> ((:) <$> noneOf "{" <*> many (noneOf "$\n\r")))++raw :: Parser InLine+raw = Raw <$> many1 (noneOf "$\n\r")++----+arrange :: [(Indent, Line)] -> [(Indent, Line)]+arrange = norm . rev . foldl (flip push) []+ where+ isCtrlNothing (_, CtrlNothing) = True+ isCtrlNothing _ = False+ isCtrlElse (_, CtrlElse) = True+ isCtrlElse _ = False+ isCtrlOf (_, CtrlOf _) = True+ isCtrlOf _ = False++ push :: Line' -> [Line'] -> [Line']+ push x [] = x:[]+ push x ss'@((_, Normal _):_) = x:ss'++ push x@(i, _) ss'@((j, CtrlForall b e body):ss)+ | i > j = (j, CtrlForall b e (push x body)):ss+ | otherwise = x:ss'++ push x@(i, _) ss'@((j, CtrlLet b e body):ss)+ | i > j = (j, CtrlLet b e (push x body)):ss+ | otherwise = x:ss'++ push x@(i, _) ss'@((j, CtrlMaybe flg b e body alt):ss)+ | i > j = if flg+ then (j, CtrlMaybe flg b e body (push x alt)):ss+ else (j, CtrlMaybe flg b e (push x body) alt):ss+ | i == j && isCtrlNothing x+ = if flg+ then error "too many $nothing found"+ else (j, CtrlMaybe True b e body alt):ss+ | otherwise = x:ss'+ push x ((j, CtrlNothing):_) = error "orphan $nothing found"++ push x@(i, _) ss'@((j, CtrlIf flg e body alt):ss)+ | i > j = if flg+ then (j, CtrlIf flg e body (push x alt)):ss+ else (j, CtrlIf flg e (push x body) alt):ss+ | i == j && isCtrlElse x+ = if flg+ then error "too many $else found"+ else (j, CtrlIf True e body alt):ss+ | otherwise = x:ss'+ push x ((j, CtrlElse):_) = error "orphan $else found"++ push x@(i, _) ss'@((j, CtrlCase e alts):ss)+ | i > j = (j, CtrlCase e (push' x alts)):ss+ | otherwise+ = if isCtrlOf x+ then error "orphan $of found"+ else x:ss'+ push x ((j, CtrlOf _):_) = error "orphan $of found"++ push' x@(i, CtrlOf e) alts = (e, []):alts+ push' x [] = error "$of not found"+ push' x ((e, body):alts) = (e, (push x body)):alts++ rev :: [Line'] -> [Line']+ rev = foldr (\x xs -> xs ++ [rev' x]) []+ rev' :: Line' -> Line'+ rev' x@(_, Normal _) = x+ rev' (i, CtrlForall b e body)+ = (i, CtrlForall b e (rev body))+ rev' (i, CtrlLet b e body)+ = (i, CtrlLet b e (rev body))+ rev' (i, CtrlMaybe flg b e body alt)+ = (i, CtrlMaybe flg b e (rev body) (rev alt))+ rev' (i, CtrlIf flg e body alt)+ = (i, CtrlIf flg e (rev body) (rev alt))+ rev' (i, CtrlCase e alts)+ = (i, CtrlCase e (map (id *** rev) $ reverse alts))++ norm :: [Line'] -> [Line']+ norm = foldr (\x xs -> norm' x:xs) []+ norm' :: Line' -> Line'+ norm' x@(_, Normal _) = x+ norm' (i, CtrlForall b e body)+ = (i, CtrlForall b e (normsub i body ++ blockEnd))+ norm' (i, CtrlLet b e body)+ = (i, CtrlLet b e (normsub i body ++ blockEnd))+ norm' (i, CtrlMaybe flg b e body alt)+ = (i, CtrlMaybe flg b e (normsub i body ++ blockEnd) (normsub i alt ++ blockEnd))+ norm' (i, CtrlNothing) = error "orphan $nothing found"+ norm' (i, CtrlIf flg e body alt)+ = (i, CtrlIf flg e (normsub i body ++ blockEnd) (normsub i alt ++ blockEnd))+ norm' (i, CtrlElse) = error "orphan $else found"+ norm' (i, CtrlCase e alts)+ = (i, CtrlCase e (map (id *** (++ blockEnd) . normsub i) alts))+ norm' (i, CtrlOf _) = error "orphan $of found"++ normsub :: Indent -> [Line'] -> [Line']+ normsub i body = let j = minimum $ map fst body+ deIndent n = i+(n-j)+ in norm $ map (deIndent *** id) body++ blockEnd :: [Line']+ blockEnd = [(0, Normal [])]++class ToQPat a where+ toQPat :: a -> Q Pat+ concatToQPat :: [a] -> Q Pat++instance ToQPat Expr where+ toQPat (S s) = litP (stringL s)+ toQPat (I i) = litP (integerL i)+ toQPat W = wildP+ toQPat (V v) = varP (mkName v)+ toQPat (O o) = varP (mkName o)+ toQPat (E e) = concatToQPat e+ toQPat (C c) = conP (mkName c) []+ toQPat (T t) = tupP $ map concatToQPat t+ toQPat (A a e) = asP (mkName a) $ toQPat e++ -- special case for list+ concatToQPat (x:O ":":xs) = infixP (toQPat x)+ (mkName ":")+ (concatToQPat xs)+ concatToQPat ((C c):args) = conP (mkName c) $ map toQPat args+ concatToQPat ((V v):args) = varP (mkName v) -- OK?+ concatToQPat (p@(T t):[]) = toQPat p -- OK?+ concatToQPat (W:[]) = wildP -- OK?+ concatToQPat (p@(A _ _):[]) = toQPat p+ concatToQPat _ = error "don't support this pattern"++class ToQExp a where+ toQExp :: a -> Q Exp+ concatToQExp :: [a] -> Q Exp++instance ToQExp Expr where+ toQExp (S s) = litE (stringL s)+ toQExp (I i) = litE (integerL i)+ toQExp W = error "wildcard is NOT legal expression"+ toQExp (V v) = varE (mkName v)+ toQExp (O o) = varE (mkName o)+ toQExp (E e) = concatToQExp e+ toQExp (C c) = conE (mkName c)+ toQExp (T t) = tupE $ map concatToQExp t+ toQExp N = listE []+ toQExp (L l) = listE $ map concatToQExp l++ concatToQExp xs = concatToQ' Nothing xs+ where+ concatToQ' (Just acc) [] = acc+ concatToQ' Nothing [x] = toQExp x+ concatToQ' Nothing (x:xs) = concatToQ' (Just (toQExp x)) xs+ -- spacial case for list+ concatToQ' (Just acc) ((O ":"):xs)+ = infixE (Just acc)+ (conE (mkName ":"))+ (Just (concatToQExp xs))+ concatToQ' (Just acc) ((O o):xs)+ = infixE (Just acc)+ (varE (mkName o))+ (Just (concatToQExp xs))+ concatToQ' (Just acc) ((V' v'):xs)+ = infixE (Just acc)+ (varE (mkName v'))+ (Just (concatToQExp xs))+ concatToQ' (Just acc) (x:xs)+ = concatToQ' (Just (appE acc (toQExp x))) xs++instance ToQExp InLine where+ toQExp (Raw s) = litE (stringL s)+ toQExp (Quoted expr) = concatToQExp expr++ concatToQExp [] = litE (stringL "")+ concatToQExp (x:xs) = infixE (Just (toQExp x))+ (varE '(<>))+ (Just (concatToQExp xs))++instance ToQExp Line where+ toQExp (CtrlForall b e body)+ = appE (appE (appE (varE 'foldr)+ (lamE [concatToQPat b]+ (infixE (Just (concatToQExp body))+ (varE '(<>))+ Nothing)))+ (litE (stringL "")))+ (concatToQExp e)+ toQExp (CtrlMaybe flg b e body alt)+ = caseE (concatToQExp e)+ [ match (conP 'Just [concatToQPat b])+ (normalB (concatToQExp body))+ []+ , match (conP 'Nothing [])+ (normalB (concatToQExp alt))+ []+ ]+ toQExp (CtrlIf flg e body alt)+ = condE (concatToQExp e) (concatToQExp body) (concatToQExp alt)+ toQExp CtrlElse = error "illegal $else found"+ toQExp (CtrlCase e alts)+ = caseE (concatToQExp e) (map mkMatch alts)+ where+ mkMatch (e', body) = match (concatToQPat e')+ (normalB (concatToQExp body))+ []+ toQExp (CtrlOf e) = error "illegal $of found"+ toQExp (CtrlLet b e body)+ = letE [valD (concatToQPat b) (normalB $ concatToQExp e) []]+ (concatToQExp body)+ toQExp (Normal xs) = concatToQExp xs++ concatToQExp (x:[]) = toQExp x+ concatToQExp (x:xs) = infixE (Just (toQExp x))+ (varE '(<>))+ (Just (concatToQExp xs))++instance ToQExp Line' where+ toQExp (n, x@(Normal _))+ = infixE (Just (litE (stringL (replicate n ' '))))+ (varE '(<>))+ (Just (toQExp x))+ toQExp (n, x) = toQExp x -- Ctrl*++ concatToQExp [] = litE (stringL "")+ concatToQExp (x@(_, Normal _):y:ys)+ = infixE (Just (infixE (Just (toQExp x))+ (varE '(<>))+ (Just (litE (stringL "\n")))))+ (varE '(<>))+ (Just (concatToQExp (y:ys)))+ concatToQExp (x@(_, Normal _):xs)+ = infixE (Just (toQExp x))+ (varE '(<>))+ (Just (concatToQExp xs))+ concatToQExp (x:xs) = infixE (Just (toQExp x))+ (varE '(<>))+ (Just (concatToQExp xs))+