summaryrefslogtreecommitdiff
path: root/LambdaCat.hs
blob: b6beaaacdbe513f1f836266aceadfab018dcdfff (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : LambdaCat
-- Copyright   : Andreas Baldeau, Daniel Ehlers
-- License     : BSD3
-- Maintainer  : Andreas Baldeau <andreas@baldeau.net>,
--               Daniel Ehlers <danielehlers@mindeye.net>
-- Stability   : Alpha
--
-- This module (re-)exports the most important functions and datatypes you
-- need, to write your own configuration file.

module LambdaCat
    (
      -- * Main entry point
      lambdacat

      -- * Configuration
    , LambdaCatConf (..)

    , defaultConfig
    , defaultModifySupplierURI
    )
where

import Network.URI
import System.Exit
import System.IO

import Config.Dyre
import Config.Dyre.Compile

import LambdaCat.CmdArgs
import LambdaCat.Configure
import LambdaCat.Supplier
import LambdaCat.Supplier.Web
import LambdaCat.UI.Glade as UI
import LambdaCat.Utils
import LambdaCat.View.Web
    ( webView
    )

-- | Lambdacat's default configuration.
defaultConfig :: LambdaCatConf
defaultConfig = LambdaCatConf
    { modifySupplierURI = defaultModifySupplierURI
    , supplierList      = [ ( webSupplier
                            , [ "http:"
                              , "https:"
                              , "about:"
                              ]
                            )
                          ]
    , viewList          = [ ( webView
                            , [ "about:"
                              , "http:"
                              , "https:"
                              , "file:"
                              ]
                            , []
                            )
                          ]
    , homeURI           = "http://www.haskell.org"
    , defaultURI        = "about:blank"
    , defaultTitle      = "(Untitled)"
    }

-- | The URI modifier used in the default configuration. It tries to add a
-- proper protocol if none is specified.
defaultModifySupplierURI :: URI -> URI
defaultModifySupplierURI uri@URI
    { uriScheme    = ""
    , uriAuthority = Just _
    } = prepend "http://" uri
defaultModifySupplierURI uri@URI
    { uriScheme    = ""
    , uriAuthority = Nothing
    , uriPath      = '/' : _
    } = prepend "file://" uri
defaultModifySupplierURI uri@URI
    { uriScheme    = ""
    , uriAuthority = Nothing
    , uriPath      = _ : _
    } = prepend "http://" uri
defaultModifySupplierURI uri = uri

-- | Add a String to the beginning of the given URI.
prepend :: String -> URI -> URI
prepend prfx uri = stringToURI $ prfx ++ show uri

-- | This is the real main function. It is called by the dyre stack.
mainCat
    :: Maybe String   -- ^ Just the error that occured during the compilation
                      -- of the user configuration, Nothing if none occured.
    -> LambdaCatConf  -- ^ The users configuration.
    -> IO ()
mainCat e cfg = do
    maybe (return ()) error e

    setLCC cfg
    args <- getCmdArgs

    let uria = map stringToURI $ uris args
        us   = if null uria
                   then [homeURI cfg]
                   else uria

    ui <- UI.init :: IO GladeUI
    mapM_ (supplyForView (UI.update ui undefined) embedView) us

    mainLoop ui

-- | Lambdacat's main function. It processes commandline parameters, handles
-- recompilation of the user configuration and calls the real main function.
-- Use this as the main function in your user configuration file.
lambdacat
    :: LambdaCatConf -- ^ Configuration to use. Just start with
                     -- 'defaultConfig' and overwrite fields as you wish.
    -> IO ()
lambdacat cfg = do
    args <- getCmdArgs

    if recompile args
        then do
            customCompile dparams
            me <- getErrorString dparams

            case me of
                Just e -> do
                    hPutStrLn stderr e
                    exitFailure

                Nothing ->
                    return ()

        else wrapMain dparams (Nothing, cfg)

-- | Configuration for dyre.
dparams :: Params (Maybe String, LambdaCatConf)
dparams =
    let dps = defaultParams
            { projectName = "lambdacat"
            , realMain    = uncurry mainCat
            , showError   = \(_, c) s -> (Just s, c)
            , statusOut   = putStrLn
            }
    in  dps { ghcOpts = ["-eventlog"] }