]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Sym/FileSystem.hs
Sync with symantic.
[comptalang.git] / lcc / Hcompta / LCC / Sym / FileSystem.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 -- | Symantic for the file system.
4 module Hcompta.LCC.Sym.FileSystem where
5
6 import Control.Applicative (Applicative(..))
7 import Data.Eq (Eq)
8 import Data.Foldable (concat)
9 import Data.Function (($), (.))
10 import Data.Functor (Functor(..), (<$>))
11 import Data.Maybe (Maybe(..))
12 import Data.Type.Equality ((:~:)(Refl))
13 import System.IO (FilePath)
14 import Text.Show (Show(..))
15 import qualified Data.Text as Text
16 import qualified Prelude ()
17
18 import Language.Symantic.Grammar
19 import Language.Symantic
20
21 import Hcompta.LCC.Journal (PathFile(..))
22
23 -- * Class 'Sym_PathFile'
24 type instance Sym PathFile = Sym_PathFile
25 class Sym_PathFile term where
26 pathfile :: PathFile -> term PathFile
27 default pathfile :: Sym_PathFile (UnT term) => Trans term => PathFile -> term PathFile
28 pathfile = trans . pathfile
29
30 instance Sym_PathFile Eval where
31 pathfile = Eval
32 instance Sym_PathFile View where
33 pathfile a = View $ \_p _v -> Text.pack (show a)
34 instance (Sym_PathFile r1, Sym_PathFile r2) => Sym_PathFile (Dup r1 r2) where
35 pathfile x = pathfile x `Dup` pathfile x
36 instance (Sym_PathFile term, Sym_Lambda term) => Sym_PathFile (BetaT term)
37
38 instance NameTyOf PathFile where
39 nameTyOf _c = ["LCC"] `Mod` "PathFile"
40 instance ClassInstancesFor PathFile where
41 proveConstraintFor _ (TyApp _ (TyConst _ _ q) c)
42 | Just HRefl <- proj_ConstKiTy @(K PathFile) @PathFile c
43 = case () of
44 _ | Just Refl <- proj_Const @Eq q -> Just Dict
45 | Just Refl <- proj_Const @Show q -> Just Dict
46 _ -> Nothing
47 proveConstraintFor _c _q = Nothing
48 instance TypeInstancesFor PathFile
49
50 instance -- Gram_Term_AtomsFor
51 ( Gram_Rule g
52 , Gram_Alt g
53 , Gram_Comment g
54 , Gram_Source src g
55 , SymInj ss PathFile
56 ) => Gram_Term_AtomsFor src ss g PathFile where
57 g_term_atomsFor =
58 [ rule "tePathFile" $
59 lexeme $ source $
60 (\a src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ tePathFile a)
61 <$> g_pathfile
62 ]
63 where
64 g_pathfile :: CF g PathFile
65 g_pathfile =
66 fmap PathFile $
67 (:)
68 <$> char '.'
69 <*> (concat <$> some ((:) <$> char '/' <*> g_pathfile_section))
70 g_pathfile_section :: CF g FilePath
71 g_pathfile_section = some (choice $ unicat <$> [Unicat_Letter, Unicat_Number])
72 instance (Source src, SymInj ss PathFile) => ModuleFor src ss PathFile where
73 moduleFor = ["LCC", "PathFile"] `moduleWhere`
74 [
75 ]
76
77 tyPathFile :: Source src => LenInj vs => Type src vs PathFile
78 tyPathFile = tyConst @(K PathFile) @PathFile
79
80 tePathFile :: Source src => SymInj ss PathFile => PathFile -> Term src ss ts '[] (() #> PathFile)
81 tePathFile a = Term noConstraint tyPathFile $ teSym @PathFile $ pathfile a