├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── app-tpgui └── Main.hs ├── app-tui └── Main.hs ├── app-web └── Main.hs ├── app-webx └── Main.hs ├── app └── Main.hs ├── cabal.project.freeze ├── data ├── htmx.min.js.gz ├── lhx-128x128.png ├── lhx-16x16.ico ├── lhx-big.png ├── lhx.svg.gz └── mvp.css.gz ├── flake.lock ├── flake.nix ├── lhx.cabal ├── lib-assets └── Lhx │ └── Assets.hs ├── lib-browser └── Lhx │ └── Browser.hs ├── lib ├── Lhx.hs └── Lhx │ └── Parser.hs ├── plan.org └── test ├── Main.hs ├── TestParser.hs └── TestTemplate.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for lhx 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Aleksei Pirogov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Aleksei Pirogov nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Line Hyper-eXpander 2 | 3 | ![logo](data/lhx-big.png) 4 | 5 | The LHX is dual: 6 | 7 | - it is a tool to do some work 8 | - it is a sandbox to learn how to program in the Haskell language 9 | 10 | ## Idea 11 | 12 | The central idea is to make possible to transform some text line-by-line using a simple templating language: rename a group of files, generate HTML lists and tables, etc. More info you can find in the project's wiki. 13 | 14 | ## Example 15 | 16 | ``` 17 | $ ls -l /tmp/files 18 | total 0 19 | -rw-r--r-- 1 user 0 2022-10-04 09:02 one 20 | -rw-r--r-- 1 user 0 2022-10-04 09:02 three 21 | -rw-r--r-- 1 user 0 2022-10-04 09:02 two 22 | $ ls -l /tmp/files | lhx --skip-errors -e 'mv $7 $5_$7' 23 | mv one 2022-10-04_one 24 | mv three 2022-10-04_three 25 | mv two 2022-10-04_two 26 | ``` 27 | 28 | ### Nix 29 | 30 | #### Enter build environment (with all the dependencies and Cabal): 31 | 32 | ```sh 33 | nix develop 34 | ``` 35 | 36 | #### Run one-liner 37 | 38 | ```sh 39 | nix run .# 40 | ``` 41 | 42 | Example: `nix run .#lhx:exe:lhx-tui` 43 | 44 | #### Run without cloning 45 | 46 | ```sh 47 | nix run github:ruHaskell-learn/lhx#lhx:exe:lhx-tui 48 | ``` 49 | -------------------------------------------------------------------------------- /app-tpgui/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wno-unused-do-bind #-} 2 | 3 | module Main where 4 | 5 | import Data.IORef 6 | import Data.Either (rights) 7 | import Data.Text (Text) 8 | import Data.Text qualified as T 9 | import Graphics.UI.Threepenny qualified as UI 10 | import Graphics.UI.Threepenny.Events qualified as E 11 | import Graphics.UI.Threepenny.Core 12 | 13 | import Lhx (Separator(..)) 14 | import Lhx qualified 15 | import Lhx.Assets qualified 16 | import Lhx.Browser 17 | 18 | fakeInput :: [Text] 19 | fakeInput = 20 | [ "Bob Smith, 42" 21 | , "Ann Thomas, 90" 22 | ] 23 | 24 | data State = State 25 | { template :: Either Lhx.Error Lhx.Template 26 | , input :: [Lhx.Input] 27 | , inputEl :: Element 28 | , templateEl :: Element 29 | , outputEl :: Element 30 | } 31 | 32 | main :: IO () 33 | main = withBrowserOnFreePort \port -> 34 | startGUI defaultConfig { jsPort = Just port } gui 35 | 36 | gui :: Window -> UI () 37 | gui win = do 38 | -- view 39 | pure win # set UI.title "LHX" 40 | getHead win #+ 41 | [ UI.link 42 | # set UI.rel "shortcut icon" 43 | # set UI.href (T.unpack Lhx.Assets.ico) 44 | ] 45 | inp <- UI.textarea 46 | -- # set UI.enabled False 47 | # set UI.style [("height", "150px")] 48 | tpl <- UI.input 49 | out <- UI.textarea 50 | # set UI.enabled False 51 | # set UI.style [("height", "150px")] 52 | getBody win 53 | # set UI.style 54 | [ ("display", "flex") 55 | , ("flex-direction", "column") 56 | ] 57 | #+ 58 | [ pure inp 59 | , pure tpl 60 | , pure out 61 | ] 62 | UI.setFocus tpl 63 | -- state 64 | ref <- liftIO $ newIORef State 65 | { template = Right [] 66 | , input = [] 67 | , inputEl = inp 68 | , templateEl = tpl 69 | , outputEl = out 70 | } 71 | let i = unlines $ map T.unpack fakeInput 72 | set UI.value i $ pure inp 73 | changeInput ref i 74 | -- events 75 | on E.valueChange inp $ changeInput ref 76 | on E.valueChange tpl $ changeTemplate ref 77 | pure () 78 | 79 | applyState :: IORef State -> UI () 80 | applyState ref = do 81 | State{template = et, input = is, outputEl = out} <- 82 | liftIO $ readIORef ref 83 | case et of 84 | Left _ -> pure () 85 | Right t -> do 86 | let ls = rights $ map (Lhx.apply t) is 87 | pure out # set UI.value (T.unpack $ T.unlines ls) 88 | pure () 89 | 90 | changeInput :: IORef State -> String -> UI () 91 | changeInput ref val = do 92 | pureModifyState ref \s -> s 93 | { input = map (Lhx.makeInput (Separator " ")) 94 | $ T.lines $ T.pack val } 95 | applyState ref 96 | 97 | changeTemplate :: IORef State -> String -> UI () 98 | changeTemplate ref val = do 99 | State{templateEl = tpl, template = t} <- 100 | pureModifyState ref \s -> s 101 | { template = Lhx.makeTemplate $ T.pack val } 102 | case t of 103 | Left e -> 104 | let ttl = T.unpack $ Lhx.errorText e 105 | in pure tpl 106 | # set UI.style [("color", "red")] 107 | # set UI.title__ ttl 108 | Right _ -> 109 | pure tpl 110 | # set UI.style [("color", "initial")] 111 | # set UI.title__ "" 112 | applyState ref 113 | 114 | pureModifyState :: IORef State -> (State -> State) -> UI State 115 | pureModifyState ref f = liftIO $ atomicModifyIORef' ref \s -> 116 | let s' = f s 117 | in (s', s') 118 | -------------------------------------------------------------------------------- /app-tui/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Brick 4 | import Brick.Widgets.Border 5 | import Brick.Widgets.Border.Style 6 | import Brick.Widgets.Edit 7 | import qualified Graphics.Vty as Vty 8 | import Control.Monad.State hiding (State) 9 | import Data.Either (isLeft) 10 | import Data.Text (Text) 11 | import Data.Text qualified as T 12 | import Graphics.Vty.Attributes qualified as VA 13 | import Graphics.Vty.Input.Events (Event(..), Key(..), Modifier(..)) 14 | import Lens.Micro 15 | import Lens.Micro.Extras (view) 16 | import Lens.Micro.TH 17 | 18 | import Lhx qualified 19 | 20 | data Name 21 | = Input 22 | | Template 23 | | Output 24 | deriving (Show, Eq, Ord, Enum, Bounded) 25 | 26 | data State = State 27 | { _sInput :: [Text] 28 | , _sTemplateEditor :: Editor Text Name 29 | , _sTemplate :: Either Lhx.Error Lhx.Template 30 | , _sOutput :: [Text] 31 | , _sFocused :: Name 32 | } 33 | 34 | $(makeLenses 'State) 35 | 36 | main :: IO () 37 | main = void $ defaultMain @Name App 38 | { appDraw = draw 39 | , appChooseCursor = \s -> showCursorNamed $ s ^. sFocused 40 | , appHandleEvent = handle 41 | , appStartEvent = initMouse 42 | , appAttrMap = \_ -> 43 | attrMap VA.defAttr 44 | [ (editAttr, VA.defAttr) 45 | , (parsingError, VA.withForeColor VA.defAttr VA.red) 46 | ] 47 | } State 48 | { _sInput = 49 | [ "Bob Smith, 1980" 50 | , "Ann Thompson, 1970" 51 | , "John Doe" 52 | , "Jane Air, 1920, 2000" 53 | , "foobar" 54 | , "foobar" 55 | , "foobar" 56 | , "foobar" 57 | , "foobar" 58 | , "foobar" 59 | ] 60 | , _sTemplateEditor = editorText Template Nothing "" 61 | , _sTemplate = Right [] 62 | , _sOutput = [] 63 | , _sFocused = Template 64 | } 65 | 66 | draw :: State -> [Widget Name] 67 | draw s = [layout] 68 | where 69 | focus = s ^. sFocused 70 | layout = vBox [inp, tpl, out] 71 | inp = 72 | clickable Input 73 | . vLimitPercent 30 74 | . textArea (focus == Input) Input 75 | $ s ^. sInput 76 | tpl = 77 | clickable Template 78 | . vLimit (min 5 $ length . getEditContents $ s ^. sTemplateEditor) 79 | . withVScrollBars OnRight 80 | . renderEditor re True 81 | $ s ^. sTemplateEditor 82 | out = 83 | clickable Output 84 | . textArea (focus == Output) Output 85 | $ s ^. sOutput 86 | re = withAttr edAttr . txt . T.unlines 87 | edAttr 88 | | s ^. sTemplate . to isLeft = parsingError 89 | | otherwise = editAttr 90 | 91 | initMouse :: EventM n s () 92 | initMouse = do 93 | vty <- Brick.getVtyHandle 94 | let output = Vty.outputIface vty 95 | when (Vty.supportsMode output Vty.Mouse) $ 96 | liftIO $ Vty.setMode output Vty.Mouse True 97 | 98 | handle :: BrickEvent Name () -> EventM Name State () 99 | handle evt = 100 | case evt of 101 | VtyEvent (EvKey KEsc []) -> halt 102 | VtyEvent (EvKey (KChar 'c') [MCtrl]) -> halt 103 | VtyEvent (EvKey KBackTab []) -> 104 | modify $ over sFocused \case 105 | n | n == minBound -> maxBound 106 | | otherwise -> pred n 107 | VtyEvent (EvKey (KChar '\t') []) -> 108 | modify $ over sFocused \case 109 | n | n == maxBound -> minBound 110 | | otherwise -> succ n 111 | MouseDown name Vty.BLeft [] _ -> 112 | modify $ sFocused .~ name 113 | _ -> 114 | gets (view sFocused) >>= \case 115 | Input -> 116 | handleTextAreaEvents Input evt 117 | Output -> 118 | handleTextAreaEvents Output evt 119 | Template -> do 120 | zoom sTemplateEditor $ handleEditorEvent evt 121 | ed <- gets $ view sTemplateEditor 122 | modify $ sTemplate .~ case getEditContents ed of 123 | (t:_) -> Lhx.makeTemplate t 124 | _ -> Right [] 125 | updateOutput 126 | 127 | updateOutput :: MonadState State m => m () 128 | updateOutput = 129 | gets (view sTemplate) >>= \case 130 | Left _ -> pure () 131 | Right tpl -> do 132 | is <- gets $ view sInput 133 | let os = is ^.. traversed 134 | . to (Lhx.makeInput (Lhx.Separator ",")) 135 | . to (Lhx.apply tpl) 136 | . _Right 137 | modify $ sOutput .~ os 138 | 139 | textArea :: (Show n, Ord n) => Bool -> n -> [Text] -> Widget n 140 | textArea focused name = 141 | withBorderStyle bs 142 | . border 143 | . withVScrollBars OnRight 144 | . viewport name Both 145 | . txt 146 | . T.unlines 147 | where 148 | bs | focused = unicodeBold 149 | | otherwise = defaultBorderStyle 150 | 151 | parsingError :: AttrName 152 | parsingError = attrName "parsingError" 153 | 154 | handleTextAreaEvents :: n -> BrickEvent n e -> EventM n s () 155 | handleTextAreaEvents name = \case 156 | VtyEvent (EvKey KHome []) -> vScrollToBeginning vps 157 | VtyEvent (EvKey KEnd []) -> vScrollToEnd vps 158 | VtyEvent (EvKey KUp []) -> vScrollBy vps (-1) 159 | VtyEvent (EvKey KDown []) -> vScrollBy vps 1 160 | MouseDown _ Vty.BScrollUp _ _ -> vScrollBy vps (-1) 161 | MouseDown _ Vty.BScrollDown _ _ -> vScrollBy vps 1 162 | _ -> pure () 163 | where 164 | vps = viewportScroll name 165 | -------------------------------------------------------------------------------- /app-web/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Main where 5 | 6 | import Data.Either (rights) 7 | import Data.FileEmbed (embedFile) 8 | import Data.Maybe (fromMaybe) 9 | import Data.Text (Text) 10 | import Data.Text qualified as T 11 | import Text.Blaze.Html.Renderer.Text qualified as R 12 | import Text.Blaze.Html5 (Html, (!)) 13 | import Text.Blaze.Html5 qualified as H 14 | import Text.Blaze.Html5.Attributes qualified as A 15 | import Text.Blaze (toMarkup, toValue) 16 | import Web.Scotty 17 | import XStatic 18 | 19 | import Lhx qualified 20 | import Lhx.Assets qualified 21 | import Lhx.Browser 22 | 23 | data FormState = FormState 24 | { fsInput :: Text 25 | , fsTemplate :: Text 26 | , fsTemplateError :: Maybe Text 27 | , fsOutput :: Text 28 | } 29 | 30 | main :: IO () 31 | main = withBrowserOnFreePort (`scotty` app) 32 | 33 | app :: ScottyM () 34 | app = do 35 | middleware $ xstaticMiddleware 36 | [ svgIconFile 37 | , mvpCssFile 38 | ] 39 | get "/" $ view FormState 40 | { fsInput = "" 41 | , fsTemplate = "" 42 | , fsTemplateError = Nothing 43 | , fsOutput = "" 44 | } 45 | post "/" do 46 | fsInput <- param "input" 47 | fsTemplate <- param "template" 48 | oldOutput <- param "output" 49 | let (fsOutput, fsTemplateError) = 50 | case Lhx.makeTemplate fsTemplate of 51 | Left es -> (oldOutput, Just $ Lhx.errorText es) 52 | Right t -> 53 | let ls = webLines fsInput 54 | input = map (Lhx.makeInput (Lhx.Separator ",")) ls 55 | out = T.unlines . rights $ map (Lhx.apply t) input 56 | in (out, Nothing) 57 | view FormState{..} 58 | 59 | view :: FormState -> ActionM () 60 | view FormState{..} = page do 61 | H.form ! A.method "POST" $ do 62 | H.label do 63 | "Input:" 64 | H.textarea 65 | ! A.name "input" 66 | $ toMarkup fsInput 67 | let 68 | tplStyle :: Text 69 | tplStyle = case fsTemplateError of 70 | Just _ -> "border-color: red;" 71 | _ -> "" 72 | H.label do 73 | "Template:" 74 | H.input 75 | ! A.name "template" 76 | ! A.title (toValue $ fromMaybe "" fsTemplateError) 77 | ! A.style (toValue tplStyle) 78 | ! A.value (toValue fsTemplate) 79 | H.label do 80 | "Output:" 81 | H.textarea 82 | ! A.readonly (toValue True) 83 | ! A.name "output" 84 | $ toMarkup fsOutput 85 | H.button ! A.action "submit" $ "Submit" 86 | 87 | page :: Html -> ActionM () 88 | page inner = html $ R.renderHtml do 89 | H.docTypeHtml do 90 | H.head do 91 | H.title "LHX" 92 | H.link 93 | ! A.rel "shortcut icon" 94 | ! A.href (toValue Lhx.Assets.ico) 95 | H.link 96 | ! A.rel "icon" 97 | ! A.sizes "any" 98 | ! A.href "/xstatic/lhx.svg" 99 | H.link 100 | ! A.rel "stylesheet" 101 | ! A.href "/xstatic/mvp.css" 102 | H.body do 103 | inner 104 | 105 | webLines :: Text -> [Text] 106 | webLines = T.split (== '\n') . T.filter (/= '\r') 107 | 108 | svgIconFile :: XStaticFile 109 | svgIconFile = XStaticFile 110 | { xfPath = "/lhx.svg" 111 | , xfContent = Lhx.Assets.svg 112 | , xfETag = "" 113 | , xfType = "image/svg+xml" 114 | } 115 | 116 | mvpCssFile :: XStaticFile 117 | mvpCssFile = XStaticFile 118 | { xfPath = "/mvp.css" 119 | , xfContent = $(embedFile "data/mvp.css.gz") 120 | , xfETag = "" 121 | , xfType = "text/css" 122 | } 123 | -------------------------------------------------------------------------------- /app-webx/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | 4 | module Main where 5 | 6 | import Control.Applicative 7 | import Control.Monad (forever, void) 8 | import Control.Monad.IO.Class 9 | import Control.Monad.Reader (MonadReader) 10 | import Control.Monad.Reader qualified as Reader 11 | import Control.Monad.State.Strict (MonadState) 12 | import Control.Monad.State.Strict qualified as State 13 | import Web.Scotty hiding (raw) 14 | import Network.Wai 15 | import Network.Wai.Handler.WebSockets 16 | import Network.WebSockets 17 | import Data.Aeson 18 | import Data.Either (rights) 19 | import Data.FileEmbed (embedFile) 20 | import Data.Text (Text) 21 | import Data.Text qualified as T 22 | import Text.Blaze.Html.Renderer.Text qualified as R 23 | import Text.Blaze.Html5 (Html, (!)) 24 | import Text.Blaze.Html5 qualified as H 25 | import Text.Blaze.Html5.Attributes qualified as A 26 | import Text.Blaze (toMarkup, toValue) 27 | import XStatic 28 | 29 | import Lhx qualified 30 | import Lhx.Assets qualified 31 | import Lhx.Browser 32 | 33 | data WsState = WsState 34 | { wsInput :: [Lhx.Input] 35 | , wsTemplate :: Lhx.Template 36 | } 37 | 38 | data WsMessage 39 | = NewInput Text 40 | | NewTemplate Text 41 | 42 | type WsMonad m = 43 | ( MonadReader Connection m 44 | , MonadState WsState m 45 | , MonadIO m 46 | ) 47 | 48 | instance FromJSON WsMessage where 49 | parseJSON = withObject "WsMessage" \v -> 50 | (NewInput <$> v .: "input") 51 | <|> 52 | (NewTemplate <$> v .: "template") 53 | 54 | main :: IO () 55 | main = withBrowserOnFreePort (`scotty` app) 56 | 57 | app :: ScottyM () 58 | app = do 59 | middleware withWS 60 | middleware $ xstaticMiddleware 61 | [ svgIconFile 62 | , htmxJsFile 63 | ] 64 | get "/" view 65 | 66 | view :: ActionM () 67 | view = page $ wsWrapper do 68 | H.div "Input:" 69 | H.form 70 | ! H.customAttribute "hx-ws" "send" 71 | ! H.customAttribute "hx-trigger" 72 | "keyup from:[name='input'] changed delay:1s" 73 | $ do 74 | H.textarea 75 | ! A.name "input" 76 | ! A.autocomplete "off" 77 | $ "" 78 | H.div "Template:" 79 | H.form 80 | ! H.customAttribute "hx-ws" "send" 81 | ! H.customAttribute "hx-trigger" 82 | "keyup from:[name='template'] changed delay:1s" 83 | $ do 84 | H.input 85 | ! A.name "template" 86 | ! A.autocomplete "off" 87 | H.span 88 | ! A.id "template-errors" 89 | $ "" 90 | H.div "Output:" 91 | output "" 92 | where 93 | wsWrapper = H.div 94 | ! H.customAttribute "hx-ws" "connect:/" 95 | 96 | output :: Text -> Html 97 | output content = 98 | H.textarea 99 | ! A.id "output" 100 | ! A.readonly (toValue True) 101 | $ toMarkup content 102 | 103 | page :: Html -> ActionM () 104 | page inner = html $ R.renderHtml do 105 | H.docTypeHtml do 106 | H.head do 107 | H.title "LHX" 108 | H.link 109 | ! A.rel "shortcut icon" 110 | ! A.href (toValue Lhx.Assets.ico) 111 | H.link 112 | ! A.rel "icon" 113 | ! A.sizes "any" 114 | ! A.href "/xstatic/lhx.svg" 115 | H.script 116 | ! A.src "/xstatic/htmx.min.js" 117 | $ "" 118 | H.body do 119 | inner 120 | 121 | withWS :: Middleware 122 | withWS = websocketsOr defaultConnectionOptions wsApp 123 | 124 | wsApp :: ServerApp 125 | wsApp pendingConn = do 126 | conn <- acceptRequest pendingConn 127 | info "Connected" 128 | void $ handler `State.execStateT` initialState `Reader.runReaderT` conn 129 | where 130 | handler = forever do 131 | getMessage >>= \case 132 | Left msg -> info $ "Unhandled: " <> show msg 133 | Right (NewInput inp) -> handleNewInput inp 134 | Right (NewTemplate rawTpl) -> handleNewTemplate rawTpl 135 | info :: MonadIO m => String -> m () 136 | info = liftIO . putStrLn . ("WS: " <>) 137 | 138 | getMessage :: (MonadReader Connection m, MonadIO m) => m (Either DataMessage WsMessage) 139 | getMessage = do 140 | conn <- Reader.ask 141 | msg <- liftIO $ receiveDataMessage conn 142 | case msg of 143 | Text raw Nothing -> 144 | case decode raw of 145 | Nothing -> pure $ Left msg 146 | Just x -> pure $ Right x 147 | _ -> pure $ Left msg 148 | 149 | handleNewInput :: WsMonad m => Text -> m () 150 | handleNewInput inp = do 151 | State.modify \s -> 152 | s { wsInput = 153 | map (Lhx.makeInput (Lhx.Separator ",")) 154 | (T.lines inp) 155 | } 156 | updateOutput 157 | 158 | handleNewTemplate :: WsMonad m => Text -> m () 159 | handleNewTemplate rawTpl = do 160 | case Lhx.makeTemplate rawTpl of 161 | Left es -> 162 | sendHtml 163 | $ H.span 164 | ! A.id "template-errors" 165 | ! A.title (toValue $ Lhx.errorText es) 166 | ! A.style "color: red;" 167 | $ "⚠" 168 | Right tpl -> do 169 | sendHtml 170 | $ H.span 171 | ! A.id "template-errors" 172 | $ "" 173 | State.modify \s -> s { wsTemplate = tpl } 174 | updateOutput 175 | 176 | updateOutput :: WsMonad m => m () 177 | updateOutput = do 178 | WsState inp tpl <- State.get 179 | let ls = rights $ map (Lhx.apply tpl) inp 180 | sendHtml $ output $ T.unlines ls 181 | 182 | sendHtml :: (MonadReader Connection m, MonadIO m) => Html -> m () 183 | sendHtml el = do 184 | conn <- Reader.ask 185 | liftIO $ sendTextData conn . R.renderHtml $ el 186 | 187 | initialState :: WsState 188 | initialState = WsState 189 | { wsInput = [] 190 | , wsTemplate = [] 191 | } 192 | 193 | svgIconFile :: XStaticFile 194 | svgIconFile = XStaticFile 195 | { xfPath = "/lhx.svg" 196 | , xfContent = Lhx.Assets.svg 197 | , xfETag = "" 198 | , xfType = "image/svg+xml" 199 | } 200 | 201 | htmxJsFile :: XStaticFile 202 | htmxJsFile = XStaticFile 203 | { xfPath = "/htmx.min.js" 204 | , xfContent = $(embedFile "data/htmx.min.js.gz") 205 | , xfETag = "" 206 | , xfType = "application/javascript" 207 | } 208 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.IO 4 | import System.Exit 5 | import Control.Monad 6 | import Data.Text qualified as T 7 | import Data.Text.IO qualified as TIO 8 | import Options.Applicative 9 | 10 | import Lhx 11 | 12 | data Options = Options 13 | { expression :: String 14 | , quiet :: Bool 15 | , skipErrors :: Bool 16 | , fieldSeparator :: String 17 | } deriving Show 18 | 19 | main :: IO () 20 | main = do 21 | opts <- execParser cli 22 | tpl <- case makeTemplate (T.pack $ expression opts) of 23 | Right t -> pure t 24 | Left es -> do 25 | unless (quiet opts) $ 26 | dumpErrors es 27 | exitWith (ExitFailure 1) 28 | ls <- map T.pack . lines <$> getContents 29 | let prepare = makeInput . Separator . T.pack $ fieldSeparator opts 30 | forM_ ls $ \l -> 31 | case apply tpl (prepare l) of 32 | Right v -> TIO.putStrLn v 33 | Left es -> 34 | unless (skipErrors opts) $ dumpErrors es 35 | 36 | dumpErrors :: Error -> IO () 37 | dumpErrors = TIO.hPutStrLn stderr . Lhx.errorText 38 | 39 | cli :: ParserInfo Options 40 | cli = info (options <**> helper) 41 | ( fullDesc 42 | <> progDesc "expands some lines" 43 | <> header "Line Hyper Expander" ) 44 | 45 | options :: Parser Options 46 | options = Options 47 | <$> strOption 48 | ( long "expression" 49 | <> short 'e' 50 | <> metavar "EXPR" 51 | <> help "Expression to expand" ) 52 | <*> switch 53 | ( long "quiet" 54 | <> short 'q' 55 | <> help "Don't print any errors" ) 56 | <*> switch 57 | ( long "skip-errors" 58 | <> help "Skip lines with errors" ) 59 | <*> option nonEmptyStr 60 | ( long "field-separator" 61 | <> short 'f' 62 | <> metavar "STRING" 63 | <> value " " 64 | <> help "Sequence that separates input's fields" ) 65 | 66 | nonEmptyStr :: ReadM String 67 | nonEmptyStr = 68 | eitherReader $ \s -> 69 | if null s 70 | then Left "Field separator can't be an empty string" 71 | else Right s 72 | -------------------------------------------------------------------------------- /cabal.project.freeze: -------------------------------------------------------------------------------- 1 | active-repositories: hackage.haskell.org:merge 2 | constraints: any.Cabal ==3.2.1.0, 3 | any.HUnit ==1.6.2.0, 4 | any.OneTuple ==0.3.1, 5 | any.QuickCheck ==2.14.2, 6 | QuickCheck -old-random +templatehaskell, 7 | any.SHA ==1.6.4.4, 8 | SHA -exe, 9 | any.StateVar ==1.2.2, 10 | any.adjunctions ==4.4.2, 11 | any.aeson ==2.0.2.0, 12 | aeson -bytestring-builder -cffi +ordered-keymap, 13 | any.ansi-terminal ==0.11.3, 14 | ansi-terminal -example, 15 | any.ansi-wl-pprint ==0.6.9, 16 | ansi-wl-pprint -example, 17 | any.appar ==0.1.8, 18 | any.array ==0.5.4.0, 19 | any.asn1-encoding ==0.9.6, 20 | any.asn1-parse ==0.9.5, 21 | any.asn1-types ==0.3.4, 22 | any.assoc ==1.0.2, 23 | any.async ==2.2.4, 24 | async -bench, 25 | any.attoparsec ==0.13.2.5, 26 | attoparsec -developer, 27 | any.auto-update ==0.1.6, 28 | any.base ==4.14.3.0, 29 | any.base-compat ==0.12.2, 30 | any.base-compat-batteries ==0.12.2, 31 | any.base-orphans ==0.8.7, 32 | any.base64-bytestring ==1.2.1.0, 33 | any.basement ==0.0.15, 34 | any.bifunctors ==5.5.12, 35 | bifunctors +semigroups +tagged, 36 | any.bimap ==0.5.0, 37 | any.binary ==0.8.8.0, 38 | any.blaze-builder ==0.4.2.2, 39 | any.blaze-html ==0.9.1.2, 40 | any.blaze-markup ==0.8.2.8, 41 | any.brick ==1.1, 42 | brick -demos, 43 | any.bsb-http-chunked ==0.0.0.4, 44 | any.byteorder ==1.0.4, 45 | any.bytestring ==0.10.12.0, 46 | any.bytestring-builder ==0.10.8.2.0, 47 | bytestring-builder +bytestring_has_builder, 48 | any.cabal-doctest ==1.0.9, 49 | any.call-stack ==0.4.0, 50 | any.case-insensitive ==1.2.1.0, 51 | any.clock ==0.8.3, 52 | clock -llvm, 53 | any.colour ==2.3.6, 54 | any.comonad ==5.0.8, 55 | comonad +containers +distributive +indexed-traversable, 56 | any.config-ini ==0.2.4.0, 57 | config-ini -enable-doctests, 58 | any.containers ==0.6.5.1, 59 | any.contravariant ==1.5.5, 60 | contravariant +semigroups +statevar +tagged, 61 | any.cookie ==0.4.5, 62 | any.cryptonite ==0.30, 63 | cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, 64 | any.data-clist ==0.2, 65 | any.data-default ==0.7.1.1, 66 | any.data-default-class ==0.1.2.0, 67 | any.data-default-instances-containers ==0.0.1, 68 | any.data-default-instances-dlist ==0.0.1, 69 | any.data-default-instances-old-locale ==0.0.1, 70 | any.data-fix ==0.3.2, 71 | any.deepseq ==1.4.4.0, 72 | any.directory ==1.3.6.0, 73 | any.distributive ==0.6.2.1, 74 | distributive +semigroups +tagged, 75 | any.dlist ==1.0, 76 | dlist -werror, 77 | any.easy-file ==0.2.2, 78 | any.entropy ==0.4.1.10, 79 | entropy -donotgetentropy, 80 | any.exceptions ==0.10.4, 81 | any.fail ==4.9.0.0, 82 | any.fast-logger ==3.1.1, 83 | any.file-embed ==0.0.15.0, 84 | any.filepath ==1.4.2.1, 85 | any.free ==5.1.9, 86 | any.ghc-boot-th ==8.10.7, 87 | any.ghc-prim ==0.6.1, 88 | any.hashable ==1.4.1.0, 89 | hashable +containers +integer-gmp -random-initial-seed, 90 | any.hourglass ==0.2.12, 91 | any.hsc2hs ==0.68.8, 92 | hsc2hs -in-ghc-tree, 93 | any.http-date ==0.0.11, 94 | any.http-types ==0.12.3, 95 | any.http2 ==3.0.3, 96 | http2 -devel -doc -h2spec, 97 | any.indexed-traversable ==0.1.2, 98 | any.indexed-traversable-instances ==0.1.1.1, 99 | any.integer-gmp ==1.0.3.0, 100 | any.integer-logarithms ==1.0.3.1, 101 | integer-logarithms -check-bounds +integer-gmp, 102 | any.invariant ==0.6, 103 | any.io-streams ==1.5.2.2, 104 | io-streams +network -nointeractivetests +zlib, 105 | any.io-streams-haproxy ==1.0.1.0, 106 | any.iproute ==1.7.12, 107 | any.kan-extensions ==5.2.5, 108 | any.lens ==5.2, 109 | lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, 110 | any.lifted-base ==0.2.3.12, 111 | any.megaparsec ==9.2.1, 112 | megaparsec -dev, 113 | any.memory ==0.18.0, 114 | memory +support_bytestring +support_deepseq, 115 | any.microlens ==0.4.13.0, 116 | any.microlens-mtl ==0.2.0.2, 117 | any.microlens-th ==0.4.3.10, 118 | any.mime-types ==0.1.0.9, 119 | any.monad-control ==1.0.3.1, 120 | any.mtl ==2.2.2, 121 | any.nats ==1.1.2, 122 | nats +binary +hashable +template-haskell, 123 | any.network ==3.1.2.7, 124 | network -devel, 125 | any.network-byte-order ==0.1.6, 126 | any.network-uri ==2.6.4.1, 127 | any.old-locale ==1.0.0.7, 128 | any.old-time ==1.1.0.3, 129 | any.optparse-applicative ==0.17.0.0, 130 | optparse-applicative +process, 131 | any.parallel ==3.2.2.0, 132 | any.parsec ==3.1.14.0, 133 | any.parser-combinators ==1.3.0, 134 | parser-combinators -dev, 135 | any.pem ==0.2.4, 136 | any.port-utils ==0.2.1.0, 137 | any.pretty ==1.1.3.6, 138 | any.primitive ==0.7.4.0, 139 | any.process ==1.6.13.2, 140 | any.profunctors ==5.6.2, 141 | any.psqueues ==0.2.7.3, 142 | any.quickcheck-text ==0.1.2.1, 143 | any.random ==1.2.1.1, 144 | any.readable ==0.3.1, 145 | any.reflection ==2.1.6, 146 | reflection -slow +template-haskell, 147 | any.regex-base ==0.94.0.2, 148 | any.regex-compat ==0.95.2.1, 149 | any.regex-posix ==0.96.0.1, 150 | regex-posix -_regex-posix-clib, 151 | any.resourcet ==1.2.6, 152 | any.rts ==1.0.1, 153 | any.safe ==0.3.19, 154 | any.scientific ==0.3.7.0, 155 | scientific -bytestring-builder -integer-simple, 156 | any.scotty ==0.12, 157 | any.semialign ==1.2.0.1, 158 | semialign +semigroupoids, 159 | any.semigroupoids ==5.3.7, 160 | semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, 161 | any.semigroups ==0.20, 162 | semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, 163 | any.simple-sendfile ==0.2.30, 164 | simple-sendfile +allow-bsd, 165 | any.snap-core ==1.0.5.0, 166 | snap-core -debug +network-uri -portable, 167 | any.snap-server ==1.1.2.0, 168 | snap-server -build-pong -build-testserver -debug -openssl -portable, 169 | any.splitmix ==0.1.0.4, 170 | splitmix -optimised-mixer, 171 | any.stm ==2.5.0.1, 172 | any.streaming-commons ==0.2.2.4, 173 | streaming-commons -use-bytestring-builder, 174 | any.strict ==0.4.0.1, 175 | strict +assoc, 176 | any.tagged ==0.8.6.1, 177 | tagged +deepseq +transformers, 178 | any.tasty ==1.4.2.3, 179 | tasty +clock +unix, 180 | any.tasty-hunit ==0.10.0.3, 181 | any.tasty-quickcheck ==0.10.2, 182 | any.template-haskell ==2.16.0.0, 183 | any.terminfo ==0.4.1.4, 184 | any.text ==1.2.4.1, 185 | any.text-short ==0.1.5, 186 | text-short -asserts, 187 | any.text-zipper ==0.12, 188 | any.th-abstraction ==0.4.4.0, 189 | any.th-compat ==0.1.4, 190 | any.these ==1.1.1.1, 191 | these +assoc, 192 | any.threepenny-gui ==0.9.1.0, 193 | threepenny-gui -buildexamples -rebug, 194 | any.time ==1.9.3, 195 | any.time-compat ==1.9.6.1, 196 | time-compat -old-locale, 197 | any.time-manager ==0.0.0, 198 | any.transformers ==0.5.6.2, 199 | any.transformers-base ==0.4.6, 200 | transformers-base +orphaninstances, 201 | any.transformers-compat ==0.7.2, 202 | transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, 203 | any.unbounded-delays ==0.1.1.1, 204 | any.unix ==2.7.2.2, 205 | any.unix-compat ==0.5.4, 206 | unix-compat -old-time, 207 | any.unix-time ==0.4.8, 208 | any.unliftio ==0.2.22.0, 209 | any.unliftio-core ==0.2.0.1, 210 | any.unordered-containers ==0.2.19.1, 211 | unordered-containers -debug, 212 | any.utf8-string ==1.0.2, 213 | any.uuid-types ==1.0.5, 214 | any.validationt ==0.3.0, 215 | any.vault ==0.3.1.5, 216 | vault +useghc, 217 | any.vector ==0.12.3.1, 218 | vector +boundschecks -internalchecks -unsafechecks -wall, 219 | any.void ==0.7.3, 220 | void -safe, 221 | any.vty ==5.36, 222 | any.wai ==3.2.3, 223 | any.wai-app-static ==3.1.7.4, 224 | wai-app-static +cryptonite -print, 225 | any.wai-extra ==3.1.12.1, 226 | wai-extra -build-example, 227 | any.wai-logger ==2.4.0, 228 | any.wai-websockets ==3.0.1.2, 229 | wai-websockets +example, 230 | any.warp ==3.3.22, 231 | warp +allow-sendfilefd -network-bytestring -warp-debug +x509, 232 | any.wcwidth ==0.0.2, 233 | wcwidth -cli +split-base, 234 | any.websockets ==0.12.7.3, 235 | websockets -example, 236 | any.websockets-snap ==0.10.3.1, 237 | any.witherable ==0.4.2, 238 | any.word-wrap ==0.5, 239 | any.word8 ==0.1.3, 240 | any.x509 ==1.7.7, 241 | any.xstatic ==0.2.0, 242 | any.zlib ==0.6.3.0, 243 | zlib -bundled-c-zlib -non-blocking-ffi -pkg-config, 244 | any.zlib-bindings ==0.1.1.5 245 | index-state: hackage.haskell.org 2022-09-11T02:19:36Z 246 | -------------------------------------------------------------------------------- /data/htmx.min.js.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ruHaskell-learn/lhx/95e8e83db5a60ba74615e8ff7df52672bf5cc524/data/htmx.min.js.gz -------------------------------------------------------------------------------- /data/lhx-128x128.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ruHaskell-learn/lhx/95e8e83db5a60ba74615e8ff7df52672bf5cc524/data/lhx-128x128.png -------------------------------------------------------------------------------- /data/lhx-16x16.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ruHaskell-learn/lhx/95e8e83db5a60ba74615e8ff7df52672bf5cc524/data/lhx-16x16.ico -------------------------------------------------------------------------------- /data/lhx-big.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ruHaskell-learn/lhx/95e8e83db5a60ba74615e8ff7df52672bf5cc524/data/lhx-big.png -------------------------------------------------------------------------------- /data/lhx.svg.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ruHaskell-learn/lhx/95e8e83db5a60ba74615e8ff7df52672bf5cc524/data/lhx.svg.gz -------------------------------------------------------------------------------- /data/mvp.css.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ruHaskell-learn/lhx/95e8e83db5a60ba74615e8ff7df52672bf5cc524/data/mvp.css.gz -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "HTTP": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1451647621, 7 | "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", 8 | "owner": "phadej", 9 | "repo": "HTTP", 10 | "rev": "9bc0996d412fef1787449d841277ef663ad9a915", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "phadej", 15 | "repo": "HTTP", 16 | "type": "github" 17 | } 18 | }, 19 | "cabal-32": { 20 | "flake": false, 21 | "locked": { 22 | "lastModified": 1603716527, 23 | "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", 24 | "owner": "haskell", 25 | "repo": "cabal", 26 | "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", 27 | "type": "github" 28 | }, 29 | "original": { 30 | "owner": "haskell", 31 | "ref": "3.2", 32 | "repo": "cabal", 33 | "type": "github" 34 | } 35 | }, 36 | "cabal-34": { 37 | "flake": false, 38 | "locked": { 39 | "lastModified": 1640353650, 40 | "narHash": "sha256-N1t6M3/wqj90AEdRkeC8i923gQYUpzSr8b40qVOZ1Rk=", 41 | "owner": "haskell", 42 | "repo": "cabal", 43 | "rev": "942639c18c0cd8ec53e0a6f8d120091af35312cd", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "haskell", 48 | "ref": "3.4", 49 | "repo": "cabal", 50 | "type": "github" 51 | } 52 | }, 53 | "cabal-36": { 54 | "flake": false, 55 | "locked": { 56 | "lastModified": 1641652457, 57 | "narHash": "sha256-BlFPKP4C4HRUJeAbdembX1Rms1LD380q9s0qVDeoAak=", 58 | "owner": "haskell", 59 | "repo": "cabal", 60 | "rev": "f27667f8ec360c475027dcaee0138c937477b070", 61 | "type": "github" 62 | }, 63 | "original": { 64 | "owner": "haskell", 65 | "ref": "3.6", 66 | "repo": "cabal", 67 | "type": "github" 68 | } 69 | }, 70 | "cardano-shell": { 71 | "flake": false, 72 | "locked": { 73 | "lastModified": 1608537748, 74 | "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", 75 | "owner": "input-output-hk", 76 | "repo": "cardano-shell", 77 | "rev": "9392c75087cb9a3d453998f4230930dea3a95725", 78 | "type": "github" 79 | }, 80 | "original": { 81 | "owner": "input-output-hk", 82 | "repo": "cardano-shell", 83 | "type": "github" 84 | } 85 | }, 86 | "flake-compat": { 87 | "flake": false, 88 | "locked": { 89 | "lastModified": 1635892615, 90 | "narHash": "sha256-harGbMZr4hzat2BWBU+Y5OYXlu+fVz7E4WeQzHi5o8A=", 91 | "owner": "input-output-hk", 92 | "repo": "flake-compat", 93 | "rev": "eca47d3377946315596da653862d341ee5341318", 94 | "type": "github" 95 | }, 96 | "original": { 97 | "owner": "input-output-hk", 98 | "repo": "flake-compat", 99 | "type": "github" 100 | } 101 | }, 102 | "flake-utils": { 103 | "locked": { 104 | "lastModified": 1659877975, 105 | "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=", 106 | "owner": "numtide", 107 | "repo": "flake-utils", 108 | "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0", 109 | "type": "github" 110 | }, 111 | "original": { 112 | "owner": "numtide", 113 | "repo": "flake-utils", 114 | "type": "github" 115 | } 116 | }, 117 | "flake-utils_2": { 118 | "locked": { 119 | "lastModified": 1644229661, 120 | "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", 121 | "owner": "numtide", 122 | "repo": "flake-utils", 123 | "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", 124 | "type": "github" 125 | }, 126 | "original": { 127 | "owner": "numtide", 128 | "repo": "flake-utils", 129 | "type": "github" 130 | } 131 | }, 132 | "ghc-8.6.5-iohk": { 133 | "flake": false, 134 | "locked": { 135 | "lastModified": 1600920045, 136 | "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", 137 | "owner": "input-output-hk", 138 | "repo": "ghc", 139 | "rev": "95713a6ecce4551240da7c96b6176f980af75cae", 140 | "type": "github" 141 | }, 142 | "original": { 143 | "owner": "input-output-hk", 144 | "ref": "release/8.6.5-iohk", 145 | "repo": "ghc", 146 | "type": "github" 147 | } 148 | }, 149 | "hackage": { 150 | "flake": false, 151 | "locked": { 152 | "lastModified": 1665623671, 153 | "narHash": "sha256-BKaaOQ/w8JU5IXAB8SrXegifXzrEte1CoyNz0RwKaUM=", 154 | "owner": "input-output-hk", 155 | "repo": "hackage.nix", 156 | "rev": "9f3b3ba469545b50e4f915019c538b69a93ac34f", 157 | "type": "github" 158 | }, 159 | "original": { 160 | "owner": "input-output-hk", 161 | "repo": "hackage.nix", 162 | "type": "github" 163 | } 164 | }, 165 | "haskellNix": { 166 | "inputs": { 167 | "HTTP": "HTTP", 168 | "cabal-32": "cabal-32", 169 | "cabal-34": "cabal-34", 170 | "cabal-36": "cabal-36", 171 | "cardano-shell": "cardano-shell", 172 | "flake-compat": "flake-compat", 173 | "flake-utils": "flake-utils_2", 174 | "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", 175 | "hackage": "hackage", 176 | "hpc-coveralls": "hpc-coveralls", 177 | "hydra": "hydra", 178 | "nixpkgs": [ 179 | "haskellNix", 180 | "nixpkgs-unstable" 181 | ], 182 | "nixpkgs-2003": "nixpkgs-2003", 183 | "nixpkgs-2105": "nixpkgs-2105", 184 | "nixpkgs-2111": "nixpkgs-2111", 185 | "nixpkgs-2205": "nixpkgs-2205", 186 | "nixpkgs-unstable": "nixpkgs-unstable", 187 | "old-ghc-nix": "old-ghc-nix", 188 | "stackage": "stackage" 189 | }, 190 | "locked": { 191 | "lastModified": 1665637141, 192 | "narHash": "sha256-lEf6IeScHkj2WGkhkW7GEenMojVNMcE1Q0e6DVTZVbY=", 193 | "owner": "input-output-hk", 194 | "repo": "haskell.nix", 195 | "rev": "0837156c56cb5350dd9bd84eb424187e00aa1e8a", 196 | "type": "github" 197 | }, 198 | "original": { 199 | "owner": "input-output-hk", 200 | "repo": "haskell.nix", 201 | "type": "github" 202 | } 203 | }, 204 | "hpc-coveralls": { 205 | "flake": false, 206 | "locked": { 207 | "lastModified": 1607498076, 208 | "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", 209 | "owner": "sevanspowell", 210 | "repo": "hpc-coveralls", 211 | "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", 212 | "type": "github" 213 | }, 214 | "original": { 215 | "owner": "sevanspowell", 216 | "repo": "hpc-coveralls", 217 | "type": "github" 218 | } 219 | }, 220 | "hydra": { 221 | "inputs": { 222 | "nix": "nix", 223 | "nixpkgs": [ 224 | "haskellNix", 225 | "hydra", 226 | "nix", 227 | "nixpkgs" 228 | ] 229 | }, 230 | "locked": { 231 | "lastModified": 1646878427, 232 | "narHash": "sha256-KtbrofMtN8GlM7D+n90kixr7QpSlVmdN+vK5CA/aRzc=", 233 | "owner": "NixOS", 234 | "repo": "hydra", 235 | "rev": "28b682b85b7efc5cf7974065792a1f22203a5927", 236 | "type": "github" 237 | }, 238 | "original": { 239 | "id": "hydra", 240 | "type": "indirect" 241 | } 242 | }, 243 | "lowdown-src": { 244 | "flake": false, 245 | "locked": { 246 | "lastModified": 1633514407, 247 | "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", 248 | "owner": "kristapsdz", 249 | "repo": "lowdown", 250 | "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", 251 | "type": "github" 252 | }, 253 | "original": { 254 | "owner": "kristapsdz", 255 | "repo": "lowdown", 256 | "type": "github" 257 | } 258 | }, 259 | "nix": { 260 | "inputs": { 261 | "lowdown-src": "lowdown-src", 262 | "nixpkgs": "nixpkgs", 263 | "nixpkgs-regression": "nixpkgs-regression" 264 | }, 265 | "locked": { 266 | "lastModified": 1643066034, 267 | "narHash": "sha256-xEPeMcNJVOeZtoN+d+aRwolpW8mFSEQx76HTRdlhPhg=", 268 | "owner": "NixOS", 269 | "repo": "nix", 270 | "rev": "a1cd7e58606a41fcf62bf8637804cf8306f17f62", 271 | "type": "github" 272 | }, 273 | "original": { 274 | "owner": "NixOS", 275 | "ref": "2.6.0", 276 | "repo": "nix", 277 | "type": "github" 278 | } 279 | }, 280 | "nixpkgs": { 281 | "locked": { 282 | "lastModified": 1632864508, 283 | "narHash": "sha256-d127FIvGR41XbVRDPVvozUPQ/uRHbHwvfyKHwEt5xFM=", 284 | "owner": "NixOS", 285 | "repo": "nixpkgs", 286 | "rev": "82891b5e2c2359d7e58d08849e4c89511ab94234", 287 | "type": "github" 288 | }, 289 | "original": { 290 | "id": "nixpkgs", 291 | "ref": "nixos-21.05-small", 292 | "type": "indirect" 293 | } 294 | }, 295 | "nixpkgs-2003": { 296 | "locked": { 297 | "lastModified": 1620055814, 298 | "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", 299 | "owner": "NixOS", 300 | "repo": "nixpkgs", 301 | "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", 302 | "type": "github" 303 | }, 304 | "original": { 305 | "owner": "NixOS", 306 | "ref": "nixpkgs-20.03-darwin", 307 | "repo": "nixpkgs", 308 | "type": "github" 309 | } 310 | }, 311 | "nixpkgs-2105": { 312 | "locked": { 313 | "lastModified": 1659914493, 314 | "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", 315 | "owner": "NixOS", 316 | "repo": "nixpkgs", 317 | "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", 318 | "type": "github" 319 | }, 320 | "original": { 321 | "owner": "NixOS", 322 | "ref": "nixpkgs-21.05-darwin", 323 | "repo": "nixpkgs", 324 | "type": "github" 325 | } 326 | }, 327 | "nixpkgs-2111": { 328 | "locked": { 329 | "lastModified": 1659446231, 330 | "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", 331 | "owner": "NixOS", 332 | "repo": "nixpkgs", 333 | "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", 334 | "type": "github" 335 | }, 336 | "original": { 337 | "owner": "NixOS", 338 | "ref": "nixpkgs-21.11-darwin", 339 | "repo": "nixpkgs", 340 | "type": "github" 341 | } 342 | }, 343 | "nixpkgs-2205": { 344 | "locked": { 345 | "lastModified": 1663981975, 346 | "narHash": "sha256-TKaxWAVJR+a5JJauKZqibmaM5e/Pi5tBDx9s8fl/kSE=", 347 | "owner": "NixOS", 348 | "repo": "nixpkgs", 349 | "rev": "309faedb8338d3ae8ad8f1043b3ccf48c9cc2970", 350 | "type": "github" 351 | }, 352 | "original": { 353 | "owner": "NixOS", 354 | "ref": "nixpkgs-22.05-darwin", 355 | "repo": "nixpkgs", 356 | "type": "github" 357 | } 358 | }, 359 | "nixpkgs-regression": { 360 | "locked": { 361 | "lastModified": 1643052045, 362 | "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", 363 | "owner": "NixOS", 364 | "repo": "nixpkgs", 365 | "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", 366 | "type": "github" 367 | }, 368 | "original": { 369 | "id": "nixpkgs", 370 | "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", 371 | "type": "indirect" 372 | } 373 | }, 374 | "nixpkgs-unstable": { 375 | "locked": { 376 | "lastModified": 1663905476, 377 | "narHash": "sha256-0CSwRKaYravh9v6qSlBpM0gNg0UhKT2lL7Yn6Zbx7UM=", 378 | "owner": "NixOS", 379 | "repo": "nixpkgs", 380 | "rev": "e14f9fb57315f0d4abde222364f19f88c77d2b79", 381 | "type": "github" 382 | }, 383 | "original": { 384 | "owner": "NixOS", 385 | "ref": "nixpkgs-unstable", 386 | "repo": "nixpkgs", 387 | "type": "github" 388 | } 389 | }, 390 | "old-ghc-nix": { 391 | "flake": false, 392 | "locked": { 393 | "lastModified": 1631092763, 394 | "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", 395 | "owner": "angerman", 396 | "repo": "old-ghc-nix", 397 | "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", 398 | "type": "github" 399 | }, 400 | "original": { 401 | "owner": "angerman", 402 | "ref": "master", 403 | "repo": "old-ghc-nix", 404 | "type": "github" 405 | } 406 | }, 407 | "root": { 408 | "inputs": { 409 | "flake-utils": "flake-utils", 410 | "haskellNix": "haskellNix", 411 | "nixpkgs": [ 412 | "haskellNix", 413 | "nixpkgs-unstable" 414 | ] 415 | } 416 | }, 417 | "stackage": { 418 | "flake": false, 419 | "locked": { 420 | "lastModified": 1665537461, 421 | "narHash": "sha256-60tLFJ0poKp3IIPMvIDx3yzmjwrX7CngypfCQqV+oXE=", 422 | "owner": "input-output-hk", 423 | "repo": "stackage.nix", 424 | "rev": "fbf47f75f32aedcdd97143ec59c578f403fae35f", 425 | "type": "github" 426 | }, 427 | "original": { 428 | "owner": "input-output-hk", 429 | "repo": "stackage.nix", 430 | "type": "github" 431 | } 432 | } 433 | }, 434 | "root": "root", 435 | "version": 7 436 | } 437 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | haskellNix.url = github:input-output-hk/haskell.nix; 4 | nixpkgs.follows = "haskellNix/nixpkgs-unstable"; 5 | flake-utils.url = github:numtide/flake-utils; 6 | }; 7 | outputs = { self, nixpkgs, flake-utils, haskellNix }: 8 | flake-utils.lib.eachDefaultSystem (system: 9 | let 10 | overlays = [ haskellNix.overlay 11 | (final: prev: { 12 | lhx = 13 | final.haskell-nix.project' { 14 | src = ./.; 15 | compiler-nix-name = "ghc8107"; 16 | shell = { 17 | exactDeps = true; 18 | tools.cabal = {}; 19 | }; 20 | }; 21 | }) 22 | ]; 23 | pkgs = import nixpkgs { inherit system overlays; inherit (haskellNix) config; }; 24 | flake = pkgs.lhx.flake {}; 25 | in flake // { 26 | devShells.minimal = pkgs.lhx-minimal.shell; 27 | legacyPackages = pkgs; 28 | }); 29 | 30 | nixConfig = { 31 | extra-substituters = ["https://cache.iog.io"]; 32 | extra-trusted-public-keys = ["hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ="]; 33 | # allow-import-from-derivation = "true"; 34 | }; 35 | } 36 | -------------------------------------------------------------------------------- /lhx.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: lhx 3 | version: 0.1.0.0 4 | synopsis: A simple line-by-line templating engine 5 | homepage: https://github.com/ruHaskell-learn/lhx 6 | license: BSD-3-Clause 7 | license-file: LICENSE 8 | author: Aleksei Pirogov 9 | maintainer: astynax@users.noreply.github.com 10 | category: Text 11 | extra-source-files: 12 | CHANGELOG.md 13 | README.md 14 | 15 | data-files: 16 | data/lhx.svg.gz 17 | data/lhx-16x16.ico 18 | data/mvp.css.gz 19 | data/htmx.min.js.gz 20 | 21 | common defaults 22 | default-language: Haskell2010 23 | build-depends: base >=4.14.3.0 24 | default-extensions: 25 | BlockArguments 26 | ImportQualifiedPost 27 | OverloadedStrings 28 | TupleSections 29 | TypeApplications 30 | LambdaCase 31 | FlexibleContexts 32 | 33 | ghc-options: 34 | -Wall -Wcompat -Wincomplete-record-updates 35 | -Wincomplete-uni-patterns -Wredundant-constraints 36 | -Wmissing-exported-signatures 37 | 38 | common scotty-app 39 | import: defaults 40 | build-depends: lhx 41 | , lhx-assets 42 | , lhx-browser 43 | , text 44 | , scotty 45 | , blaze-html 46 | , blaze-markup 47 | , xstatic 48 | 49 | library 50 | import: defaults 51 | hs-source-dirs: lib 52 | exposed-modules: 53 | Lhx 54 | Lhx.Parser 55 | 56 | build-depends: 57 | , megaparsec 58 | , text 59 | , mtl 60 | , containers 61 | , validationt 62 | 63 | library lhx-assets 64 | import: defaults 65 | hs-source-dirs: lib-assets 66 | exposed-modules: 67 | Lhx.Assets 68 | build-depends: 69 | , text 70 | , bytestring 71 | , file-embed 72 | 73 | library lhx-browser 74 | import: defaults 75 | hs-source-dirs: lib-browser 76 | exposed-modules: 77 | Lhx.Browser 78 | build-depends: 79 | , process 80 | , port-utils 81 | 82 | executable lhx 83 | import: defaults 84 | hs-source-dirs: app 85 | main-is: Main.hs 86 | build-depends: lhx 87 | , text 88 | , optparse-applicative 89 | 90 | executable lhx-tui 91 | import: defaults 92 | hs-source-dirs: app-tui 93 | main-is: Main.hs 94 | ghc-options: -threaded 95 | default-extensions: 96 | TemplateHaskell 97 | build-depends: lhx 98 | , text 99 | , brick 100 | , vty 101 | , microlens 102 | , microlens-th 103 | , mtl 104 | 105 | executable lhx-tpgui 106 | import: defaults 107 | hs-source-dirs: app-tpgui 108 | main-is: Main.hs 109 | ghc-options: -threaded 110 | build-depends: lhx 111 | , lhx-assets 112 | , lhx-browser 113 | , text 114 | , threepenny-gui 115 | 116 | executable lhx-web 117 | import: scotty-app 118 | hs-source-dirs: app-web 119 | main-is: Main.hs 120 | ghc-options: -threaded 121 | build-depends: file-embed 122 | 123 | executable lhx-webx 124 | import: scotty-app 125 | hs-source-dirs: app-webx 126 | main-is: Main.hs 127 | ghc-options: -threaded 128 | build-depends: file-embed 129 | , wai 130 | , wai-websockets 131 | , websockets 132 | , aeson 133 | , mtl 134 | 135 | test-suite lhx-test 136 | import: defaults 137 | type: exitcode-stdio-1.0 138 | hs-source-dirs: test 139 | main-is: Main.hs 140 | other-modules: TestParser, TestTemplate 141 | build-depends: lhx 142 | , text 143 | , quickcheck-text 144 | , tasty 145 | , tasty-hunit 146 | , tasty-quickcheck 147 | -------------------------------------------------------------------------------- /lib-assets/Lhx/Assets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Lhx.Assets where 4 | 5 | import Data.ByteString 6 | import Data.FileEmbed 7 | import Data.Text 8 | 9 | ico :: Text 10 | ico = "data:image/x-icon;base64,\ 11 | \AAABAAEAEBAQAAEABAAoAQAAFgAAACgAAAAQAAAAIAAAAAEABAAAAAAAgAAAAC4BAAAuAQAAEAAA\ 12 | \ABAAAAAAEwEAAC8AAAB4BAAGEwYAAnYCAEcvdQAAAP8AAIAAAACKUgAAn58AAOTkAP8AAABNNE0A\ 13 | \ewN7ADFPMQCMAHQAz+/f7O7+/v715fX1XF9cX+REXzVTPzRO03cQmqkVd83d0nIpoScu3d3uR3dy\ 14 | \JO7d3UEREAABBN3dQAlZhZAE3d1BCYmYkATd3UERAFARFN3d7kcid3Tt3d3id4qody7d3nggCqUC\ 15 | \dz3ENTM1UzNETMbG5vW/vLy/7+/s787+/v4AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\ 16 | \AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" 17 | 18 | svg :: ByteString 19 | svg = $(embedFile "data/lhx.svg.gz") 20 | -------------------------------------------------------------------------------- /lib-browser/Lhx/Browser.hs: -------------------------------------------------------------------------------- 1 | module Lhx.Browser where 2 | 3 | import Control.Monad (void) 4 | import Control.Concurrent 5 | import Network.Socket.Free (getFreePort) 6 | import Network.Socket.Wait (waitWith) 7 | import System.Process 8 | 9 | withBrowserOnFreePort :: (Int -> IO ()) -> IO () 10 | withBrowserOnFreePort serveOn = do 11 | port <- getFreePort 12 | void $ forkIO do 13 | waitWith mempty 100000 "127.0.0.1" port 14 | void . spawnCommand $ "xdg-open http://127.0.0.1:" <> show port 15 | serveOn port 16 | 17 | withFreePort :: (Int -> IO ()) -> IO () 18 | withFreePort = (getFreePort >>=) 19 | -------------------------------------------------------------------------------- /lib/Lhx.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Lhx 4 | ( Error(), errorText 5 | , Input(..), Separator(..), makeInput 6 | , Template, makeTemplate, apply, functions 7 | ) where 8 | 9 | import Control.Monad 10 | import Control.Monad.Identity 11 | import Control.Monad.Except 12 | import Control.Monad.State.Strict 13 | import Control.Monad.Validation 14 | import Data.Bifunctor 15 | import Data.List (scanl') 16 | import Data.Map (Map) 17 | import Data.Map qualified as Map 18 | import Data.Maybe 19 | import Data.Text (Text) 20 | import Data.Text qualified as T 21 | 22 | import Lhx.Parser hiding (Raw, Apply) 23 | import Lhx.Parser qualified as Parser 24 | 25 | newtype Error = Error [Text] deriving (Show, Eq, Semigroup, Monoid) 26 | 27 | newtype Separator = Separator { unSeparator :: Text } deriving (Show) 28 | 29 | type Template = [Op] 30 | 31 | data Op 32 | = Put Text 33 | | Apply Int [(Key, Transformation)] 34 | 35 | type Transformation = Text -> Either Error Text 36 | 37 | newtype Key = Key { unKey :: [Text] } deriving (Eq, Ord, Show) 38 | 39 | data Input = Input 40 | { iRaw :: !Text 41 | , iFields :: [Text] 42 | } deriving (Show, Eq) 43 | 44 | type Cache = Map Int (Map Key Text) 45 | 46 | apply :: Template -> Input -> Either Error Text 47 | apply tpl i = 48 | T.concat <$> 49 | runValidationTEither (traverse (applyOpTo i) tpl) 50 | `evalState` Map.empty 51 | 52 | applyOpTo :: Input -> Op -> ValidationT Error (State Cache) Text 53 | applyOpTo _ (Put t) = pure t 54 | applyOpTo inp (Apply idx steps) = do 55 | cache <- lift $ state \s -> case Map.lookup idx s of 56 | Nothing -> let x = Map.empty in (x, Map.insert idx x s) 57 | Just x -> (x, s) 58 | res <- runExceptT do 59 | t <- liftEither $ at idx inp 60 | (t', cache') <- runStateT (go t steps) cache 61 | lift . lift . modify $ Map.insert idx cache' 62 | pure t' 63 | case res of 64 | Left e -> "" <$ vWarning e 65 | Right x -> pure x 66 | where 67 | go t [] = pure t 68 | go t ((k, f) : fs) = do 69 | cache <- get 70 | case Map.lookup k cache of 71 | Just r -> pure r 72 | Nothing -> do 73 | t' <- go t fs 74 | r <- liftEither $ f t' 75 | modify $ Map.insert k r 76 | pure r 77 | 78 | makeInput :: Separator -> Text -> Input 79 | makeInput (Separator sep) s = Input s (T.splitOn sep s) 80 | 81 | functions :: [(FName, Transformation)] 82 | functions = 83 | [ (FName "rev", Right . T.reverse) 84 | , (FName "strip", Right . T.strip) 85 | , (FName "lstrip", Right . T.stripStart) 86 | , (FName "rstrip", Right . T.stripEnd) 87 | ] 88 | 89 | lookupFunction :: Monad m => FName -> ValidationT Error m (Maybe Transformation) 90 | lookupFunction n = do 91 | let f = lookup n functions 92 | when (isNothing f) $ 93 | vWarning $ Error ["Unknown function: " <> unFName n] 94 | pure f 95 | 96 | buildTemplate :: [Chunk] -> Either Error Template 97 | buildTemplate = 98 | fmap catMaybes . runIdentity . runValidationTEither . traverse useChunk 99 | where 100 | useChunk (Parser.Raw t) = pure . Just $ Put t 101 | useChunk (Parser.Apply idx ns) = 102 | fmap (Apply idx . addKeys) . sequence <$> traverse lookupFunction ns 103 | where 104 | addKeys = zip (buildPrefixesReversed ns) 105 | 106 | -- | Builds a list of prefixes (reversed) from a list of function names 107 | -- 108 | -- >>> buildPrefixesReversed [FName "f", FName "g", FName "h"] 109 | -- [Key {unKey = ["f"]},Key {unKey = ["g","f"]},Key {unKey = ["h","g","f"]}] 110 | buildPrefixesReversed :: [FName] -> [Key] 111 | buildPrefixesReversed = tail . scanl' step (Key []) 112 | where 113 | step (Key p) (FName n) = Key (n : p) 114 | 115 | makeTemplate :: Text -> Either Error Template 116 | makeTemplate = buildTemplate <=< first wrap . parse 117 | where 118 | wrap err = Error [err] 119 | 120 | at :: Int -> Input -> Either Error Text 121 | at 0 Input{iRaw = raw} = Right raw 122 | at ix Input{iFields = fs} = 123 | case drop (abs ix - 1) (prepare fs) of 124 | (x:_) -> Right x 125 | _ -> Left $ Error ["Index is out of range: " <> T.pack (show ix)] 126 | where 127 | prepare 128 | | ix < 0 = reverse 129 | | otherwise = id 130 | 131 | errorText :: Error -> Text 132 | errorText (Error xs) = T.unlines xs 133 | -------------------------------------------------------------------------------- /lib/Lhx/Parser.hs: -------------------------------------------------------------------------------- 1 | module Lhx.Parser 2 | ( FName(..) 3 | , Chunk(..) 4 | , parse 5 | ) where 6 | 7 | import Data.Bifunctor 8 | import Data.Void 9 | import Data.Text as T 10 | import Text.Megaparsec hiding (parse) 11 | import Text.Megaparsec qualified as MP 12 | import Text.Megaparsec.Char 13 | import Text.Megaparsec.Char.Lexer (signed, decimal) 14 | 15 | newtype FName = FName { unFName :: Text } deriving (Show, Eq) 16 | 17 | data Chunk 18 | = Raw Text 19 | | Apply Int [FName] 20 | deriving (Show, Eq) 21 | 22 | type Parser a = Parsec Void Text a 23 | 24 | parse :: Text -> Either Text [Chunk] 25 | parse = 26 | first (T.pack . errorBundlePretty) 27 | . MP.parse templateP "" 28 | 29 | templateP :: Parser [Chunk] 30 | templateP = Prelude.concat <$> many tokenP 31 | 32 | tokenP :: Parser [Chunk] 33 | tokenP = 34 | try escapeP 35 | <|> applyP 36 | <|> (:[]) <$> rawP 37 | 38 | rawP :: Parser Chunk 39 | rawP = Raw . T.pack <$> some (satisfy (/= '$')) 40 | 41 | applyP :: Parser [Chunk] 42 | applyP = 43 | char '$' *> do 44 | app <- applyP' 45 | r <- optional rawP 46 | case r of 47 | Just (Raw t) 48 | | T.take 1 t == ":" -> fail "Expected ;" 49 | | otherwise -> pure [app, Raw t] 50 | _ -> pure [app] 51 | where 52 | applyP' = 53 | (Apply 54 | <$> signed (pure ()) decimal 55 | <*> (try (char ':' *> namesP) <|> pure [])) 56 | <|> 57 | (Apply 0 <$> namesP) 58 | 59 | namesP :: Parser [FName] 60 | namesP = (fmap FName identP `sepBy1` char ':') <* char ';' 61 | 62 | identP :: Parser Text 63 | identP = 64 | cons 65 | <$> lowerChar 66 | <*> (T.pack <$> many (lowerChar <|> digitChar)) 67 | 68 | escapeP :: Parser [Chunk] 69 | escapeP = char '$' *> char '$' *> pure [Raw "$"] 70 | -------------------------------------------------------------------------------- /plan.org: -------------------------------------------------------------------------------- 1 | * App 2 | | Subsystem | Library | 3 | |---------------+---------------------------------| 4 | | Parsers | megaparsec | 5 | | Tests | tasty | 6 | | CLI | optparse-applicative (generic?) | 7 | | TUI | brick | 8 | | Web-based GUI | threepennygui | 9 | | WebApp | scotty | 10 | | embedded Lua | hslua | 11 | * CLI 12 | ** ~-e EXPR~ 13 | ** ~-i LIB~ 14 | * Infra 15 | ** Nix 16 | ** Docker 17 | ** CI on different OSes 18 | * Template language 19 | #+BEGIN_SRC text 20 | : ts = %time{YY-MM-DD} 21 | mv %f %i{03}-%fne-%ts 22 | #+END_SRC 23 | ** awk(1) 24 | *** ~@include~ 25 | *** ~$0~, ~$1~… 26 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Tasty (defaultMain, testGroup) 4 | import TestParser qualified 5 | import TestTemplate qualified 6 | 7 | main :: IO () 8 | main = 9 | defaultMain $ 10 | testGroup 11 | "Lhx tests" 12 | [ TestParser.tests 13 | , TestTemplate.tests 14 | ] 15 | -------------------------------------------------------------------------------- /test/TestParser.hs: -------------------------------------------------------------------------------- 1 | module TestParser (tests) where 2 | 3 | import Data.Either (isLeft) 4 | import Data.Text (Text) 5 | import Data.Text qualified as T 6 | import Data.Text.Arbitrary () 7 | import Test.Tasty (TestTree, testGroup) 8 | import Test.Tasty.HUnit (testCase, (@?), (@?=)) 9 | 10 | import Lhx.Parser qualified as LP 11 | 12 | (?=>) :: Text -> [LP.Chunk] -> TestTree 13 | input ?=> chunks = 14 | testCase (T.unpack input) $ LP.parse input @?= Right chunks 15 | 16 | functionCallParsingTests :: TestTree 17 | functionCallParsingTests = 18 | testGroup 19 | "Functions" 20 | [ "$foo;" ?=> [LP.Apply 0 [LP.FName "foo"]] 21 | , "$1:foo;" ?=> [LP.Apply 1 [LP.FName "foo"]] 22 | , "$foo:bar;" ?=> [LP.Apply 0 [LP.FName "foo", LP.FName "bar"]] 23 | , "$8:foo1:bar2:baz3;" ?=> 24 | [LP.Apply 8 [LP.FName "foo1", LP.FName "bar2", LP.FName "baz3"]] 25 | , "$a1s2d3;" ?=> [LP.Apply 0 [LP.FName "a1s2d3"]] 26 | , "$4abc" ?=> [LP.Apply 4 [], LP.Raw "abc"] 27 | , "$+7" ?=> [LP.Apply 7 []] 28 | , "$-7" ?=> [LP.Apply (-7) []] 29 | , "$-0" ?=> [LP.Apply 0 []] 30 | , "$-12:foo:bar:baz;" ?=> [LP.Apply (-12) [LP.FName "foo", LP.FName "bar", LP.FName "baz"]] 31 | ] 32 | 33 | rawTextParsingTests :: TestTree 34 | rawTextParsingTests = 35 | testGroup 36 | "Raw text" 37 | [ "just text" ?=> [LP.Raw "just text"] 38 | , ";;;; qwerty ;; asd ; ; ; '' :" ?=> 39 | [LP.Raw ";;;; qwerty ;; asd ; ; ; '' :"] 40 | , "$$" ?=> [LP.Raw "$"] 41 | ] 42 | 43 | complexTemplateParsingTests :: TestTree 44 | complexTemplateParsingTests = 45 | testGroup 46 | "Complex templates" 47 | [ "a$foo;b$1:bar;" ?=> 48 | [ LP.Raw "a", LP.Apply 0 [LP.FName "foo"] 49 | , LP.Raw "b", LP.Apply 1 [LP.FName "bar"] 50 | ] 51 | , "; $798745987234:foo:bar:baz:bazzz:rev;; : " ?=> 52 | [ LP.Raw "; " 53 | , LP.Apply 798745987234 54 | [ LP.FName "foo", LP.FName "bar", LP.FName "baz" 55 | , LP.FName "bazzz", LP.FName "rev" 56 | ] 57 | , LP.Raw "; : " 58 | ] 59 | ] 60 | 61 | correctTemplatesTests :: TestTree 62 | correctTemplatesTests = 63 | testGroup 64 | "right" 65 | [ functionCallParsingTests 66 | , rawTextParsingTests 67 | , complexTemplateParsingTests 68 | ] 69 | 70 | (@!!) :: Text -> String -> TestTree 71 | input @!! message = 72 | testCase (T.unpack input) $ isLeft (LP.parse input) @? message 73 | 74 | brokenTemplateTests :: TestTree 75 | brokenTemplateTests = 76 | testGroup 77 | "Broken templates" 78 | [ "$" @!! "Sole $ shouldn't be parsed" 79 | , "$ foo;" @!! "Function name cannot contain non alphanumeric chars" 80 | , "$;" @!! "Function name cannot be empty" 81 | , "$12:4abc;" @!! "Function name cannot start with a digit" 82 | , "$foo" @!! "Even a sole function call should be terminated with ;" 83 | , "$9783535:foo:bar:baz:bazzz:a:b:c:d:e" 84 | @!! "Any complex call should be terminated with ;" 85 | , "$- 12" @!! "There must not be a space after the sign" 86 | ] 87 | 88 | tests :: TestTree 89 | tests = 90 | testGroup 91 | "Parser tests" 92 | [ correctTemplatesTests 93 | , brokenTemplateTests 94 | ] 95 | -------------------------------------------------------------------------------- /test/TestTemplate.hs: -------------------------------------------------------------------------------- 1 | module TestTemplate (tests) where 2 | 3 | import Data.Bifunctor (first) 4 | import Data.Either (isLeft, isRight, fromRight) 5 | import Data.Text qualified as T 6 | import Data.Text.Arbitrary () 7 | import Test.Tasty (TestTree, testGroup) 8 | import Test.Tasty.HUnit (testCase, (@?), (@?=)) 9 | import Test.Tasty.QuickCheck qualified as QC 10 | 11 | import Lhx (Separator(..)) 12 | import Lhx qualified 13 | import Lhx.Parser qualified as LP 14 | 15 | templateMakingTests :: TestTree 16 | templateMakingTests = 17 | testGroup 18 | "Making of templates" 19 | [ testGroup 20 | "Broken templates" 21 | [ testCase "Unclosed function call" $ 22 | isLeft (Lhx.makeTemplate "$foo") 23 | @? "Shouldn't accept non-closed function call" 24 | , testCase "Unknown function" $ 25 | isLeft (Lhx.makeTemplate "$foo;") 26 | @? "Shouldn't accept unknown function" 27 | , testCase "Several unknown functions" $ 28 | case Lhx.makeTemplate "$foo:bar:rev:baz:rev:bazzz:rev;" of 29 | Right _ -> error "impossible" 30 | Left e -> Lhx.errorText e @?= T.unlines 31 | [ "Unknown function: foo" 32 | , "Unknown function: bar" 33 | , "Unknown function: baz" 34 | , "Unknown function: bazzz" 35 | ] 36 | ] 37 | , testGroup 38 | "Correct templates" 39 | [ testCase "All known functions" $ 40 | isRight (Lhx.makeTemplate $ mconcat 41 | [ "$" 42 | , T.intercalate ":" $ map (LP.unFName . fst) Lhx.functions 43 | , ";" 44 | ]) @? "Should accept any registered function" 45 | ] 46 | ] 47 | 48 | inputMakingTests :: TestTree 49 | inputMakingTests = 50 | testGroup 51 | "Make input" 52 | [ testCase "Separating by ','" $ 53 | Lhx.iFields (Lhx.makeInput (Lhx.Separator ",") "a, b, c") 54 | @?= ["a", " b", " c"] 55 | ] 56 | 57 | functionPropertyTests :: TestTree 58 | functionPropertyTests = 59 | testGroup 60 | "Function properties" 61 | [ QC.testProperty "'rev' function" \s -> 62 | fromRight False do 63 | template <- Lhx.makeTemplate "$rev;" 64 | result <- Lhx.apply template (Lhx.makeInput (Separator ",") s) 65 | pure $ result == T.reverse s 66 | ] 67 | 68 | indexingTests :: TestTree 69 | indexingTests = 70 | testGroup 71 | "Indexing" 72 | [ testCase "Zero index should capture the whole input" $ 73 | "$0" `appliedTo` "abcd" @?= Right "abcd" 74 | , testCase "Two fields should be swaped" $ 75 | "$2,$1" `appliedTo` "a,b" @?= Right "b,a" 76 | , testCase "Functions should work well with indices" $ 77 | "$2:rev:rev;,$1:rev;" `appliedTo` "abc,de" @?= Right "de,cba" 78 | , testCase "Index out of range" $ 79 | "$20" `appliedTo` "a,b,c" @?= Left "Index is out of range: 20\n" 80 | , testCase "Negate index -1" $ 81 | "$-1" `appliedTo` "a,b,c,d,e,f" @?= Right "f" 82 | , testCase "Negate index -3" $ 83 | "$-3" `appliedTo` "a,b,c,d,e,f" @?= Right "d" 84 | , testCase "Negate index out of range" $ 85 | "$-3" `appliedTo` "a,b" @?= Left "Index is out of range: -3\n" 86 | , testCase "To apply the function on the negate index" $ 87 | "$-3:rev;" `appliedTo` "a,b,c,abcd,e,f" @?= Right "dcba" 88 | ] 89 | where 90 | appliedTo templateT inputString = first Lhx.errorText do 91 | template <- Lhx.makeTemplate templateT 92 | Lhx.apply template (Lhx.makeInput (Separator ",") inputString) 93 | 94 | tests :: TestTree 95 | tests = 96 | testGroup 97 | "Templating tests" 98 | [ templateMakingTests 99 | , inputMakingTests 100 | , functionPropertyTests 101 | , indexingTests 102 | ] 103 | --------------------------------------------------------------------------------